Code:
''' <summary>
''' Findet alle annotativen Objekte und Viewports, 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, Styles und Viewports durchsuchen
' ═══════════════════════════════════════════════════════
Dim report As New StringBuilder()
Dim foundObjects As New List(Of FoundObjectInfo)()
Dim foundViewports As New List(Of ViewportInfo)()
Dim foundStyles As New List(Of String)()
report.AppendLine("╔════════════════════════════════════════════════════════╗")
report.AppendLine("║ OBJEKTE MIT BESCHRIFTUNGSMASZSTAB: " & selectedScale.Name.PadRight(16) & "║")
report.AppendLine("╚════════════════════════════════════════════════════════╝")
report.AppendLine()
' ═══════════════════════════════════════════════════════
' DIMENSION STYLES durchsuchen
' ═══════════════════════════════════════════════════════
Dim dimStyleTable As DimStyleTable = DirectCast(tr.GetObject(db.DimStyleTableId, OpenMode.ForRead), DimStyleTable)
For Each dimStyleId As ObjectId In dimStyleTable
Dim dimStyle As DimStyleTableRecord = DirectCast(tr.GetObject(dimStyleId, OpenMode.ForRead), DimStyleTableRecord)
If dimStyle.Annotative = AnnotativeStates.True Then
If dimStyle.HasContext(selectedContext) Then
foundStyles.Add($"DimStyle: {dimStyle.Name}")
End If
End If
Next
' ═══════════════════════════════════════════════════════
' TEXT STYLES durchsuchen
' ═══════════════════════════════════════════════════════
Dim textStyleTable As TextStyleTable = DirectCast(tr.GetObject(db.TextStyleTableId, OpenMode.ForRead), TextStyleTable)
For Each textStyleId As ObjectId In textStyleTable
Dim textStyle As TextStyleTableRecord = DirectCast(tr.GetObject(textStyleId, OpenMode.ForRead), TextStyleTableRecord)
If textStyle.HasContext(selectedContext) Then
foundStyles.Add($"TextStyle: {textStyle.Name}")
End If
Next
' ═══════════════════════════════════════════════════════
' MULTILEADER STYLES durchsuchen
' ═══════════════════════════════════════════════════════
Try
Dim mleaderDictId As ObjectId = db.MLeaderStyleDictionaryId
If Not mleaderDictId.IsNull Then
Dim mleaderDict As DBDictionary = DirectCast(tr.GetObject(mleaderDictId, OpenMode.ForRead), DBDictionary)
For Each entry As DBDictionaryEntry In mleaderDict
Dim mleaderStyle As MLeaderStyle = DirectCast(tr.GetObject(entry.Value, OpenMode.ForRead), MLeaderStyle)
If mleaderStyle.Annotative = AnnotativeStates.True Then
If mleaderStyle.HasContext(selectedContext) Then
foundStyles.Add($"MLeaderStyle: {entry.Key}")
End If
End If
Next
End If
Catch
End Try
' ═══════════════════════════════════════════════════════
' TABLE STYLES durchsuchen
' ═══════════════════════════════════════════════════════
Try
Dim tableStyleDictId As ObjectId = db.TableStyleDictionaryId
If Not tableStyleDictId.IsNull Then
Dim tableStyleDict As DBDictionary = DirectCast(tr.GetObject(tableStyleDictId, OpenMode.ForRead), DBDictionary)
For Each entry As DBDictionaryEntry In tableStyleDict
Dim tableStyle As TableStyle = DirectCast(tr.GetObject(entry.Value, OpenMode.ForRead), TableStyle)
If tableStyle.HasContext(selectedContext) Then
foundStyles.Add($"TableStyle: {entry.Key}")
End If
Next
End If
Catch
End Try
' ═══════════════════════════════════════════════════════
' VIEWPORTS durchsuchen
' ═══════════════════════════════════════════════════════
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)
For Each objId As ObjectId In paperBtr
Dim obj As DBObject = tr.GetObject(objId, OpenMode.ForRead)
If TypeOf obj Is Viewport Then
Dim vp As Viewport = DirectCast(obj, Viewport)
If vp.AnnotationScale = selectedScale Then
Dim center As Point3d = vp.CenterPoint
Dim vpInfo As New ViewportInfo() With {
.LayoutName = layout.LayoutName,
.Position = $"X={center.X:F2}, Y={center.Y:F2}",
.ViewCenter = vp.ViewCenter,
.Width = vp.Width,
.Height = vp.Height
}
foundViewports.Add(vpInfo)
End If
End If
Next
End If
Next
' ═══════════════════════════════════════════════════════
' ANNOTATIVE OBJEKTE durchsuchen
' ═══════════════════════════════════════════════════════
Dim bt As BlockTable = DirectCast(tr.GetObject(db.BlockTableId, OpenMode.ForRead), BlockTable)
' MODEL SPACE
Dim modelBtr As BlockTableRecord = DirectCast(tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForRead), BlockTableRecord)
Dim modelCountBefore As Integer = foundObjects.Count
SearchBlockTableRecord(modelBtr, "Model", "", selectedContext, foundObjects, report, tr)
Dim modelFound As Integer = foundObjects.Count - modelCountBefore
' PAPER SPACE (alle Layouts)
Dim paperCountBefore As Integer = foundObjects.Count
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
Dim paperFound As Integer = foundObjects.Count - paperCountBefore
' BLÖCKE
Dim blockCountBefore As Integer = foundObjects.Count
For Each btId As ObjectId In bt
Dim btr As BlockTableRecord = DirectCast(tr.GetObject(btId, OpenMode.ForRead), BlockTableRecord)
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
Dim blockFound As Integer = foundObjects.Count - blockCountBefore
' ═══════════════════════════════════════════════════════
' ZUSAMMENFASSUNG
' ═══════════════════════════════════════════════════════
report.AppendLine()
report.AppendLine("═════════════════════════════════════════════════════════")
report.AppendLine("║ ZUSAMMENFASSUNG ║")
report.AppendLine("═════════════════════════════════════════════════════════")
report.AppendLine()
report.AppendLine($"Beschriftungsmaßstab: {selectedScale.Name} ({selectedScale.DrawingUnits}:{selectedScale.PaperUnits})")
report.AppendLine()
report.AppendLine($"Gefundene Styles: {foundStyles.Count}")
report.AppendLine($"Gefundene Viewports: {foundViewports.Count}")
report.AppendLine($"Gefundene annotative Objekte: {foundObjects.Count}")
If foundObjects.Count > 0 Then
report.AppendLine($" • Model Space: {modelFound}")
report.AppendLine($" • Paper Space: {paperFound}")
report.AppendLine($" • Blöcke: {blockFound}")
End If
report.AppendLine()
Dim totalFound As Integer = foundStyles.Count + foundViewports.Count + foundObjects.Count
' STYLES LISTE
If foundStyles.Count > 0 Then
report.AppendLine("─────────────────────────────────────────────────────────")
report.AppendLine("STYLES MIT DIESEM MAZSTAB:")
report.AppendLine()
For Each styleName In foundStyles
report.AppendLine($" • {styleName}")
Next
report.AppendLine()
report.AppendLine("⚠ WICHTIG: Styles müssen zuerst bereinigt werden!")
report.AppendLine()
End If
' VIEWPORTS LISTE
If foundViewports.Count > 0 Then
report.AppendLine("─────────────────────────────────────────────────────────")
report.AppendLine("VIEWPORTS MIT DIESEM MAZSTAB:")
report.AppendLine()
For Each vp In foundViewports
report.AppendLine($"● Viewport in '{vp.LayoutName}'")
report.AppendLine($" Position: {vp.Position}")
report.AppendLine($" Größe: {vp.Width:F2} x {vp.Height:F2}")
report.AppendLine()
Next
End If
' OBJEKTE LISTE (nur wenn gefunden)
If foundObjects.Count > 0 Then
report.AppendLine("─────────────────────────────────────────────────────────")
report.AppendLine("ANNOTATIVE OBJEKTE MIT DIESEM MAZSTAB:")
report.AppendLine()
' Gruppiert nach Objekttyp
Dim groupedByType = foundObjects.GroupBy(Function(f) f.ObjectType).OrderBy(Function(g) g.Key)
For Each typeGroup In groupedByType
report.AppendLine($"● {typeGroup.Key} ({typeGroup.Count()} Objekte)")
report.AppendLine()
For Each obj In typeGroup.Take(10)
report.AppendLine($" • {obj.Space}")
report.AppendLine($" Layer: {obj.Layer}")
report.AppendLine($" Position: {obj.Position}")
If Not String.IsNullOrEmpty(obj.BlockPath) Then
report.AppendLine($" Block: {obj.BlockPath}")
End If
report.AppendLine()
Next
If typeGroup.Count() > 10 Then
report.AppendLine($" ... und {typeGroup.Count() - 10} weitere")
report.AppendLine()
End If
Next
report.AppendLine("─────────────────────────────────────────────────────────")
report.AppendLine()
End If
' Finale Bewertung
If totalFound = 0 Then
report.AppendLine("✓ Keine Styles, Viewports oder Objekte verwenden diesen Maßstab.")
report.AppendLine()
report.AppendLine("► Der Maßstab kann gelöscht werden!")
Else
report.AppendLine($"⚠ GESAMT: {totalFound} Referenzen auf diesen Maßstab gefunden!")
report.AppendLine()
report.AppendLine("► Der Maßstab kann NICHT gelöscht werden, solange diese")
report.AppendLine(" Referenzen existieren.")
End If
tr.Commit()
' Ausgabe
ed.WriteMessage(vbLf & report.ToString())
Catch ex As Exception
ed.WriteMessage(vbLf & "═══════════════════════════════════════════════════════")
ed.WriteMessage(vbLf & "FEHLER:")
ed.WriteMessage(vbLf & ex.Message)
If ex.StackTrace IsNot Nothing Then
ed.WriteMessage(vbLf & ex.StackTrace)
End If
ed.WriteMessage(vbLf & "═══════════════════════════════════════════════════════" & vbLf)
End Try
End Using
End Sub
''' <summary>
''' Durchsucht einen BlockTableRecord nach ALLEN annotativen 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
Dim isAnnotative As Boolean = False
Dim ent As Entity = TryCast(obj, Entity)
' Prüfen ob Objekt annotativ ist
If ent IsNot Nothing Then
isAnnotative = ent.Annotative = AnnotativeStates.True
End If
' Zusätzliche Checks für spezifische Objekttypen
Dim shouldCheck As Boolean = isAnnotative
' ALLE ANNOTATIVEN OBJEKTTYPEN:
If TypeOf obj Is DBText OrElse
TypeOf obj Is MText OrElse
TypeOf obj Is Dimension OrElse
TypeOf obj Is RotatedDimension OrElse
TypeOf obj Is AlignedDimension OrElse
TypeOf obj Is RadialDimension OrElse
TypeOf obj Is DiametricDimension OrElse
TypeOf obj Is OrdinateDimension OrElse
TypeOf obj Is ArcDimension OrElse
TypeOf obj Is BlockReference OrElse
TypeOf obj Is Hatch OrElse
TypeOf obj Is MLeader OrElse
TypeOf obj Is Table OrElse
TypeOf obj Is FeatureControlFrame Then ' Geometrische Toleranz
shouldCheck = True
End If
' Prüfen ob dieses Objekt den gesuchten Context hat
If shouldCheck AndAlso obj.HasContext(targetContext) Then
Dim position As String = GetObjectPosition(obj, ent)
Dim detailedType As String = GetDetailedObjectType(obj)
Dim info As New FoundObjectInfo() With {
.Space = spaceName,
.ObjectType = detailedType,
.Layer = If(ent IsNot Nothing, ent.Layer, "<kein Layer>"),
.Position = position,
.BlockPath = blockPath
}
foundObjects.Add(info)
foundInSpace += 1
report.AppendLine($" ✓ {info.ObjectType}")
report.AppendLine($" Layer: {info.Layer}")
report.AppendLine($" Position: {info.Position}")
If Not String.IsNullOrEmpty(blockPath) Then
report.AppendLine($" → {blockPath}")
End If
report.AppendLine()
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
' NUR AUSGABE WENN OBJEKTE GEFUNDEN WURDEN!
If foundInSpace > 0 Then
report.AppendLine($" → Gefunden: {foundInSpace} von {objectsInSpace} Objekten")
report.AppendLine()
End If
End Sub
''' <summary>
''' Ermittelt die Position eines Objekts
''' </summary>
Private Function GetObjectPosition(obj As DBObject, ent As Entity) As String
Dim position As String = "<keine Position>"
If ent IsNot Nothing Then
Try
' Versuche GeometricExtents
Dim bounds As Extents3d = ent.GeometricExtents
Dim center As Point3d = New Point3d(
(bounds.MinPoint.X + bounds.MaxPoint.X) / 2,
(bounds.MinPoint.Y + bounds.MaxPoint.Y) / 2,
(bounds.MinPoint.Z + bounds.MaxPoint.Z) / 2
)
position = $"X={center.X:F2}, Y={center.Y:F2}, Z={center.Z:F2}"
Catch
' Fallback: Spezifische Properties
Try
If TypeOf ent Is DBText Then
Dim txt As DBText = DirectCast(ent, DBText)
position = $"X={txt.Position.X:F2}, Y={txt.Position.Y:F2}, Z={txt.Position.Z:F2}"
ElseIf TypeOf ent Is MText Then
Dim mtxt As MText = DirectCast(ent, MText)
position = $"X={mtxt.Location.X:F2}, Y={mtxt.Location.Y:F2}, Z={mtxt.Location.Z:F2}"
ElseIf TypeOf ent Is Dimension Then
Dim ddim As Dimension = DirectCast(ent, Dimension)
position = $"X={ddim.TextPosition.X:F2}, Y={ddim.TextPosition.Y:F2}, Z={ddim.TextPosition.Z:F2}"
ElseIf TypeOf ent Is BlockReference Then
Dim blk As BlockReference = DirectCast(ent, BlockReference)
position = $"X={blk.Position.X:F2}, Y={blk.Position.Y:F2}, Z={blk.Position.Z:F2}"
ElseIf TypeOf ent Is Hatch Then
Dim hatch As Hatch = DirectCast(ent, Hatch)
position = $"X={hatch.GeometricExtents.ToString}"
ElseIf TypeOf ent Is MLeader Then
Dim mleader As MLeader = DirectCast(ent, MLeader)
position = $"X={mleader.TextLocation.X:F2}, Y={mleader.TextLocation.Y:F2}, Z={mleader.TextLocation.Z:F2}"
ElseIf TypeOf ent Is Table Then
Dim table As Table = DirectCast(ent, Table)
position = $"X={table.Position.X:F2}, Y={table.Position.Y:F2}, Z={table.Position.Z:F2}"
ElseIf TypeOf ent Is FeatureControlFrame Then
Dim fcf As FeatureControlFrame = DirectCast(ent, FeatureControlFrame)
position = $"X={fcf.Location.X:F2}, Y={fcf.Location.Y:F2}, Z={fcf.Location.Z:F2}"
End If
Catch
' Konnte keine Position ermitteln
End Try
End Try
End If
Return position
End Function
''' <summary>
''' Liefert einen detaillierten Objekttyp-Namen
''' </summary>
Private Function GetDetailedObjectType(obj As DBObject) As String
If TypeOf obj Is DBText Then
Return "Text (einzeilig)"
ElseIf TypeOf obj Is MText Then
Return "MText (mehrzeilig)"
ElseIf TypeOf obj Is RotatedDimension Then
Return "Bemaßung (gedreht)"
ElseIf TypeOf obj Is AlignedDimension Then
Return "Bemaßung (ausgerichtet)"
ElseIf TypeOf obj Is RadialDimension Then
Return "Bemaßung (radial)"
ElseIf TypeOf obj Is DiametricDimension Then
Return "Bemaßung (Durchmesser)"
ElseIf TypeOf obj Is OrdinateDimension Then
Return "Bemaßung (Ordinate)"
ElseIf TypeOf obj Is ArcDimension Then
Return "Bemaßung (Bogen)"
ElseIf TypeOf obj Is Dimension Then
Return "Bemaßung (allgemein)"
ElseIf TypeOf obj Is BlockReference Then
Dim blk As BlockReference = DirectCast(obj, BlockReference)
Return $"Block ({blk.Name})"
ElseIf TypeOf obj Is Hatch Then
Return "Schraffur"
ElseIf TypeOf obj Is MLeader Then
Return "Multi-Führungslinie"
ElseIf TypeOf obj Is Table Then
Return "Tabelle"
ElseIf TypeOf obj Is FeatureControlFrame Then
Return "Geometrische Toleranz"
Else
Return obj.GetRXClass().Name
End If
End Function
''' <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 Position As String
Public Property BlockPath As String
End Class
''' <summary>
''' Info-Struktur für Viewports
''' </summary>
Private Class ViewportInfo
Public Property LayoutName As String
Public Property Position As String
Public Property ViewCenter As Point2d
Public Property Width As Double
Public Property Height As Double
End Class
Foren auf CAD.de
| 
