Code:
Imports System.Collections.Generic
Imports System.Linq
Imports System.Reflection
Imports System.Text
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Internal
Imports Autodesk.AutoCAD.Runtime' Verringern der Ladezeit beim Kompilieren
<Assembly: CommandClass(GetType(SmallTools.AnnotationScaleAnalyzer))>
Namespace SmallTools
Module AnnotationScaleAnalyzer
' Dictionary: UniqueIdentifier (als Hex-String) -> Name
Public scalesDatabase As New Dictionary(Of String, String)()
''' <summary>
''' Findet alle Objekte in der Zeichnung, die einen bestimmten Beschriftungsmaßstab verwenden
''' </summary>
<CommandMethod("FINDSCALEUSAGE")>
Public Sub FindScaleUsage()
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Using tr As Transaction = db.TransactionManager.StartTransaction()
Try
' ═══════════════════════════════════════════════════════
' SCHRITT 1: Alle Scales auflisten und Benutzer wählen lassen
' ═══════════════════════════════════════════════════════
Dim ocm As ObjectContextManager = db.ObjectContextManager
Dim occ As ObjectContextCollection = ocm.GetContextCollection("ACDB_ANNOTATIONSCALES")
If occ Is Nothing Then
ed.WriteMessage(vbLf & "✗ Keine Beschriftungsmaßstäbe in dieser Zeichnung gefunden!")
Return
End If
' Liste der Scales erstellen
Dim scalesList As New List(Of AnnotationScale)()
Dim scalesDisplay As New StringBuilder()
scalesDisplay.AppendLine(vbLf & "╔════════════════════════════════════════════════════════╗")
scalesDisplay.AppendLine("║ BESCHRIFTUNGSMASZSTÄBE IN ZEICHNUNG ║")
scalesDisplay.AppendLine("╚════════════════════════════════════════════════════════╝")
scalesDisplay.AppendLine()
Dim index As Integer = 0
For Each ctx As ObjectContext In occ
Dim scale As AnnotationScale = TryCast(ctx, AnnotationScale)
If scale IsNot Nothing Then
scalesList.Add(scale)
scalesDisplay.AppendLine($" [{index}] {scale.Name} ({scale.DrawingUnits}:{scale.PaperUnits})")
index += 1
End If
Next
scalesDisplay.AppendLine()
scalesDisplay.AppendLine($"Gesamt: {scalesList.Count} Beschriftungsmaßstäbe")
scalesDisplay.AppendLine()
ed.WriteMessage(scalesDisplay.ToString())
' Benutzer wählen lassen
Dim pio As New PromptIntegerOptions(vbLf & "Wählen Sie einen Beschriftungsmaßstab [0-" & (scalesList.Count - 1).ToString() & "]: ")
pio.AllowNone = False
pio.AllowNegative = False
pio.LowerLimit = 0
pio.UpperLimit = scalesList.Count - 1
Dim pir As PromptIntegerResult = ed.GetInteger(pio)
If pir.Status <> PromptStatus.OK Then Return
Dim selectedScale As AnnotationScale = scalesList(pir.Value)
Dim selectedContext As ObjectContext = DirectCast(selectedScale, ObjectContext)
ed.WriteMessage(vbLf & vbLf & "═══════════════════════════════════════════════════════")
ed.WriteMessage(vbLf & $"Gewählter Maßstab: {selectedScale.Name}")
ed.WriteMessage(vbLf & "═══════════════════════════════════════════════════════")
ed.WriteMessage(vbLf & vbLf & "Durchsuche Zeichnung...")
ed.WriteMessage(vbLf)
' ═══════════════════════════════════════════════════════
' SCHRITT 2: Alle Objekte durchsuchen
' ═══════════════════════════════════════════════════════
Dim report As New StringBuilder()
Dim foundObjects As New List(Of FoundObjectInfo)()
report.AppendLine("╔════════════════════════════════════════════════════════╗")
report.AppendLine("║ OBJEKTE MIT BESCHRIFTUNGSMASZSTAB: " & selectedScale.Name.PadRight(16) & "║")
report.AppendLine("╚════════════════════════════════════════════════════════╝")
report.AppendLine()
' MODEL SPACE durchsuchen
report.AppendLine("▼▼▼ MODEL SPACE ▼▼▼")
report.AppendLine()
Dim bt As BlockTable = DirectCast(tr.GetObject(db.BlockTableId, OpenMode.ForRead), BlockTable)
Dim modelBtr As BlockTableRecord = DirectCast(tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForRead), BlockTableRecord)
SearchBlockTableRecord(modelBtr, "Model", "", selectedContext, foundObjects, report, tr)
' PAPER SPACE (alle Layouts) durchsuchen
report.AppendLine()
report.AppendLine("▼▼▼ PAPER SPACE (LAYOUTS) ▼▼▼")
report.AppendLine()
Dim layoutDict As DBDictionary = DirectCast(tr.GetObject(db.LayoutDictionaryId, OpenMode.ForRead), DBDictionary)
For Each layoutEntry As DBDictionaryEntry In layoutDict
Dim layout As Layout = DirectCast(tr.GetObject(layoutEntry.Value, OpenMode.ForRead), Layout)
If layout.LayoutName <> "Model" Then
Dim paperBtr As BlockTableRecord = DirectCast(tr.GetObject(layout.BlockTableRecordId, OpenMode.ForRead), BlockTableRecord)
SearchBlockTableRecord(paperBtr, $"Layout: {layout.LayoutName}", "", selectedContext, foundObjects, report, tr)
End If
Next
' BLÖCKE durchsuchen
report.AppendLine()
report.AppendLine("▼▼▼ BLÖCKE ▼▼▼")
report.AppendLine()
For Each btId As ObjectId In bt
Dim btr As BlockTableRecord = DirectCast(tr.GetObject(btId, OpenMode.ForRead), BlockTableRecord)
' Nur benannte Blöcke (keine Layouts, keine anonymen)
If Not btr.IsLayout AndAlso Not btr.IsAnonymous AndAlso Not btr.Name.StartsWith("*") Then
SearchBlockTableRecord(btr, $"Block: {btr.Name}", "", selectedContext, foundObjects, report, tr)
End If
Next
' ═══════════════════════════════════════════════════════
' ZUSAMMENFASSUNG
' ═══════════════════════════════════════════════════════
report.AppendLine()
report.AppendLine("═════════════════════════════════════════════════════════")
report.AppendLine("║ ZUSAMMENFASSUNG ║")
report.AppendLine("═════════════════════════════════════════════════════════")
report.AppendLine()
report.AppendLine($"Beschriftungsmaßstab: {selectedScale.Name} ({selectedScale.DrawingUnits}:{selectedScale.PaperUnits})")
report.AppendLine($"Gefundene Objekte: {foundObjects.Count}")
report.AppendLine()
If foundObjects.Count > 0 Then
report.AppendLine("─────────────────────────────────────────────────────────")
report.AppendLine("DETAILLIERTE LISTE:")
report.AppendLine()
' Gruppiert nach Space/Block
Dim grouped = foundObjects.GroupBy(Function(f) f.Space).OrderBy(Function(g) g.Key)
For Each group In grouped
report.AppendLine($"● {group.Key}")
report.AppendLine()
For Each obj In group
report.AppendLine($" • {obj.ObjectType}")
report.AppendLine($" Layer: {obj.Layer}")
report.AppendLine($" Handle: {obj.Handle}")
If Not String.IsNullOrEmpty(obj.BlockPath) Then
report.AppendLine($" Block-Pfad: {obj.BlockPath}")
End If
report.AppendLine()
Next
report.AppendLine("─────────────────────────────────────────────────────────")
report.AppendLine()
Next
Else
report.AppendLine("✓ Keine Objekte verwenden diesen Beschriftungsmaßstab.")
report.AppendLine()
report.AppendLine("Der Maßstab kann sicher gelöscht werden!")
End If
tr.Commit()
' Ausgabe
ed.WriteMessage(vbLf & report.ToString())
' Auf Desktop speichern
Try
Dim desktopPath As String = Environment.GetFolderPath(Environment.SpecialFolder.Desktop)
Dim safeScaleName As String = String.Join("_", selectedScale.Name.Split(IO.Path.GetInvalidFileNameChars()))
Dim fileName As String = $"ScaleUsage_{safeScaleName}_{DateTime.Now:yyyyMMdd_HHmmss}.txt"
Dim filePath As String = IO.Path.Combine(desktopPath, fileName)
IO.File.WriteAllText(filePath, report.ToString())
ed.WriteMessage(vbLf & vbLf & "═══════════════════════════════════════════════════════")
ed.WriteMessage(vbLf & $"Datei gespeichert: {filePath}")
ed.WriteMessage(vbLf & "═══════════════════════════════════════════════════════" & vbLf)
Catch ex As Exception
ed.WriteMessage(vbLf & $"Fehler beim Speichern: {ex.Message}" & vbLf)
End Try
Catch ex As Exception
ed.WriteMessage(vbLf & "═══════════════════════════════════════════════════════")
ed.WriteMessage(vbLf & "FEHLER:")
ed.WriteMessage(vbLf & ex.Message)
ed.WriteMessage(vbLf & "═══════════════════════════════════════════════════════" & vbLf)
End Try
End Using
End Sub
''' <summary>
''' Durchsucht einen BlockTableRecord nach Objekten mit einem bestimmten Scale
''' </summary>
Private Sub SearchBlockTableRecord(btr As BlockTableRecord,
spaceName As String,
blockPath As String,
targetContext As ObjectContext,
foundObjects As List(Of FoundObjectInfo),
report As StringBuilder,
tr As Transaction)
Dim objectsInSpace As Integer = 0
Dim foundInSpace As Integer = 0
For Each objId As ObjectId In btr
Try
Dim obj As DBObject = tr.GetObject(objId, OpenMode.ForRead)
objectsInSpace += 1
' Prüfen ob dieses Objekt den gesuchten Context hat
If obj.HasContext(targetContext) Then
Dim ent As Entity = TryCast(obj, Entity)
Dim info As New FoundObjectInfo() With {
.Space = spaceName,
.ObjectType = obj.GetType().Name,
.Layer = If(ent IsNot Nothing, ent.Layer, "<kein Layer>"),
.Handle = obj.Handle.ToString(),
.BlockPath = blockPath
}
foundObjects.Add(info)
foundInSpace += 1
report.AppendLine($" ✓ {info.ObjectType} (Handle: {info.Handle}, Layer: {info.Layer})")
If Not String.IsNullOrEmpty(blockPath) Then
report.AppendLine($" → {blockPath}")
End If
End If
' Wenn es eine BlockReference ist, rekursiv in den Block gehen
If TypeOf obj Is BlockReference Then
Dim blkRef As BlockReference = DirectCast(obj, BlockReference)
Try
Dim nestedBtr As BlockTableRecord = DirectCast(tr.GetObject(blkRef.BlockTableRecord, OpenMode.ForRead), BlockTableRecord)
If Not nestedBtr.IsLayout AndAlso Not nestedBtr.IsAnonymous Then
Dim newPath As String = If(String.IsNullOrEmpty(blockPath),
nestedBtr.Name,
blockPath & " → " & nestedBtr.Name)
' REKURSIV in verschachtelten Block gehen
SearchBlockTableRecord(nestedBtr, spaceName, newPath, targetContext, foundObjects, report, tr)
End If
Catch ex As Exception
' Block nicht zugreifbar
End Try
End If
Catch ex As Exception
' Objekt überspringen
End Try
Next
If foundInSpace > 0 Then
report.AppendLine()
report.AppendLine($" Gefunden: {foundInSpace} von {objectsInSpace} Objekten")
report.AppendLine()
End If
End Sub
''' <summary>
''' Info-Struktur für gefundene Objekte
''' </summary>
Private Class FoundObjectInfo
Public Property Space As String
Public Property ObjectType As String
Public Property Layer As String
Public Property Handle As String
Public Property BlockPath As String
End Class
End Module
End Namespace
Foren auf CAD.de
| 
