[编程交流] 向每个b添加新属性

 
Sub test2()
Dim attributeObj As AcadAttribute
Dim BlockObj As AcadBlockReference
Dim BlockObj2 As AcadBlock
   For Each Elem In ThisDrawing.ModelSpace
       With Elem
           If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
               If ((Elem.HasAttributes) And (Left(Elem.EffectiveName, 3) = "G_B") Or (Left(Elem.EffectiveName, 3) = "G_E") Or _
               (Left(Elem.EffectiveName, 3) = "G_I") Or (Left(Elem.EffectiveName, 3) = "G_L")) Then
               Handle = Elem.Handle
               Dim InsertionPnt(0 To 2) As Double
               InsertionPnt(0) = 0#: InsertionPnt(1) = 0#: InsertionPnt(2) = 0#
               Set BlockObj = Elem
               Set BlockObj2 = BlockObj [color=red]<-FIRST ERROR)[/color]
               Set attributeObj = BlockObj2.AddAttribute(1, acAttributeModeInvisible, "HANDLE_ID", InsertionPnt, "HANDLE_ID", Handle) [color=red]<-SECOND ERROR)[/color]
               ThisDrawing.SendCommand "_ATTSYNC" & vbCr & "NAME" & vbCr & Elem.EffectiveName & vbCr
               End If
           End If
       End With
   Next Elem
End Sub

Set BlockObj2  = ThisDrawing.Blocks(BlockObj.Name)

Set BlockObj2  = ThisDrawing.Blocks(BlockObj.EffectiveName)

Option Explicit
Sub test2()
   Dim attributeObj As AcadAttribute
   Dim BlockObj As AcadBlockReference
   Dim BlockObj2 As AcadBlock
   Dim elem As AcadEntity
   Dim Handle As String
   Dim blockName As String
   Dim collNames As New Collection
   Dim i As Integer
   Dim j As Integer
   'collect just unique block names into collection
   For Each elem In ThisDrawing.ModelSpace
       If (TypeOf elem Is AcadBlockReference) Then
           Set BlockObj = elem
           With BlockObj
               If ((.HasAttributes) And (Left(.EffectiveName, 3) = "G_B") Or (Left(.EffectiveName, 3) = "G_E") Or _
                   (Left(.EffectiveName, 3) = "G_I") Or (Left(.EffectiveName, 3) = "G_L")) Then
                   On Error Resume Next    ' to bypass error on duplicate name
                   collNames.Add .EffectiveName, .EffectiveName
               End If
           End With
       End If
   Next elem
   Dim InsertionPnt(0 To 2) As Double
   InsertionPnt(0) = 0#: InsertionPnt(1) = 0#: InsertionPnt(2) = 0#
   ' iterate trough collection
   For i = 1 To collNames.Count
       blockName = collNames.Item(i)
       Set BlockObj2 = ThisDrawing.Blocks(blockName)
       Set attributeObj = BlockObj2.AddAttribute(1, acAttributeModeInvisible, "New prompt", InsertionPnt, "NEW_TAG", "0")
       With ThisDrawing
           .SetVariable "CMDECHO", 0
           .SendCommand "_ATTSYNC _N " & blockName & vbCr
           .SetVariable "CMDECHO", 1
           .Regen acAllViewports
       End With
   Next i
   ThisDrawing.Regen acAllViewports
   Dim ftype(1) As Integer
   ftype(0) = 0: ftype(1) = 2
   Dim fdata(1) As Variant
   fdata(0) = "INSERT"
   ' iterate trough collection again
   For i = 1 To collNames.Count
       blockName = collNames.Item(i)
       fdata(1) = "`*," & blockName
       Dim oSset As AcadSelectionSet
       
       With ThisDrawing.SelectionSets
           While .Count > 0
               .Item(0).Delete
           Wend
           Set oSset = .Add("$Blocks$")
       End With
       
       oSset.Select acSelectionSetAll, , , ftype, fdata
      
       For Each elem In oSset
           Set BlockObj = elem
           Handle = elem.Handle
           Dim atts() As AcadAttributeReference
           Dim att As AcadAttributeReference
           
           With BlockObj
               atts = .GetAttributes()
               For j = 0 To UBound(atts)
                   Set att = atts(j)
                   If att.TagString = "NEW_TAG" Then
                       att.TextString = CStr(Handle)
                       '//Exit For
                   End If
               Next j
               Exit For
           End With
           
       Next elem
       
       '//oSset.Delete
       
   Next i
   MsgBox "Get to work!"
End Sub