Add Attribute to each added item with vba

[Grenco]

Hi there!

Because i'm still working on my database connection and a user interface i've got another question.

My problem is that my routine has to work also with older drawings with old blocks. Old blocks don't have a attribute named "GEA-ID". So I want this to check/add when there is a drawing opened or an object is added.

When a drawing is opened:

Sub ACADApp_EndOpen(ByVal FileName As String)
If ThisDrawing.GetVariable("WRITESTAT") = 0 Then
Exit Sub
End If
If Not (Left(ThisDrawing.Name, 1)) = "~" Then
Exit Sub
End If
Call Check_If_CORRECT_GEA_ID_Is_In_Block
End Sub

Sub Check_If_GEA_ID_Is_In_Block() 'Elem, Handle, NewOrNot As Boolean)
Dim attributeObj As AcadAttribute
Dim BlockObj As AcadBlock
Dim InsertionPnt(0 To 2) As Double

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
Attributen = Elem.GetAttributes
Found = False

ThisDrawing.SendCommand "_ATTSYNC" & vbCr & "NAME" & vbCr & Elem.EffectiveName & vbCr 'NODIG???????

For Count = LBound(Attributen) To UBound(Attributen) 'Read attributes from block
If Attributen(Count).TagString = "GEA_ID" Then
Found = True
End If
Next Count

If Found = False Then
Set BlockObj = ThisDrawing.Blocks(Elem.EffectiveName)
InsertionPnt(0) = 0#: InsertionPnt(1) = 0#: InsertionPnt(2) = 0#
Set attributeObj = BlockObj.AddAttribute(1, acAttributeModeInvisible, "GEA_ID", InsertionPnt, "GEA_ID", "")
attributeObj.Layer = "Attrib-Hidden"
ThisDrawing.SendCommand "_ATTSYNC" & vbCr & "NAME" & vbCr & Elem.EffectiveName & vbCr
ThisDrawing.Regen (acActiveViewport) 'NODIG??
End If
End If
End If
End With
Next Elem
End Sub

This works OK. But not perfect. The sendcommand _ATTSYNC isn't fast enough. Isn't there a way to do it in the background (VBA)? Most of the drawings have more then 1000 objects so it has to send that command 1000 times. I have to do a ATTSYNC because otherwise I cant find that added attribute. Another thing with ATTSYNC is that it resets the attribute, so when an old block is mirrored and the attribute grippoint it's moved from it's original position by the user. The text is set to it's original point and it could be backwards when it was mirrored. The whole drawing is a mess then. Is there a way to fix this?

For Adding (like copying):

Public Sub AcadDocument_ObjectAdded(ByVal Elem As Object)
Dim Handle As String
Dim Attributen As Variant
Dim Found As Boolean
Dim InsertionPnt(0 To 2) As Double

On Error GoTo ErrHandler
'Renew Handle in GEA_ID Attribute
ThisDrawing.SendCommand "_ATTSYNC" & vbCr & "NAME" & vbCr & Elem.EffectiveName & vbCr

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

Attributen = Elem.GetAttributes
Found = False
For Count = LBound(Attributen) To UBound(Attributen) 'Read attributes from block
If Attributen(Count).TagString = "GEA_ID" Then
Found = True
Attributen(Count).TextString = Elem.Handle
End If
Next Count
If Found = False Then
Set BlockObj = ThisDrawing.Blocks(Elem.EffectiveName)
InsertionPnt(0) = 0#: InsertionPnt(1) = 0#: InsertionPnt(2) = 0#
Set attributeObj = BlockObj.AddAttribute(1, acAttributeModeInvisible, "GEA_ID", InsertionPnt, "GEA_ID", "")
attributeObj.Layer = "Attrib-Hidden"
ThisDrawing.SendCommand "_ATTSYNC" & vbCr & "NAME" & vbCr & Elem.EffectiveName & vbCr
ThisDrawing.Regen (acActiveViewport) 'NODIG??
End If
End If
End If
End With
Exit Sub
ErrHandler:
If Err.Number = 438 Then
Exit Sub
Else
MsgBox Err.Number & Err.Description
End If
End Sub
With this one the ATTSYNC is fast enough. Not pretty, but it works. The only thing is that when I use the AcadDocument_ObjectAdded event, it runs 2 times per element so my attribute is added 2 times. Apparently ATTSYNC doesnt make the added attribute visible for VBA so the attribute added again! What am I doing wrong?