Bei dieser Funktion können nach auführen des Befehls nur Blöcke als Objekte gewählt werden. Dann wird für jedenblock der Blockname und und sofern der Block Attribute hat alle Attribut Tag's und eingegeben Attribut Texte ausgelese....
---------------------------------------------------------------
Option Explicit
Option Base 1
Public Sub GetBlockInfo()
'########### SELECT ANWEISUNG ##########
'Selection Set deklarieren
Dim objSelection As AcadSelectionSet
'Fehlerbehandlung
On Error Resume Next
'########### Neuen SelectionSet erstellen bzw. bestenden verwenden ############
Set objSelection = ThisDrawing.SelectionSets.Add("ssBlock")
If Err Then
Err.Clear
'Fehlerbehandlung
On Error GoTo Hell
Set objSelection = ThisDrawing.SelectionSets.Item("ssBlock")
End If
'########### Bestenden Objekte aus SelectionSet bereinigen ############
objSelection.Clear
'Filtereinstellungen für Selectionset
'########### Definiert, dass nur Blöcke ausgewählt werden können ############
Dim intType(1) As Integer
Dim varValue(1) As Variant
intType(1) = 0: varValue(1) = "insert"
objSelection.SelectOnScreen intType, varValue
Dim objBlockRef As AcadBlockReference
Dim intCount As Integer
Dim varAttribute As Variant
Dim strMessage As String
'########### Schleife für jeden Block in der Auswahl ############
For Each objBlockRef In objSelection
'########### Blockname auslesen ############
strMessage = "Blockname: " & objBlockRef.Name
If objBlockRef.HasAttributes Then
varAttribute = objBlockRef.GetAttributes
'########### Abrufen aller Attribute mit Tag und Text ############
For intCount = LBound(varAttribute) To UBound(varAttribute)
strMessage = strMessage & vbCr & "Att. Tag: " & varAttribute(intCount).TagString _
& " --> Value: " & varAttribute(intCount).TextString
Next
End If
MsgBox strMessage
Next
Exit Sub
'Fehlerbehandlung
Hell:
MsgBox Err.Number & vbCr & Err.Description
Exit Sub
End Sub
------------------
Michael Mair
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de
| 
