Add Attribute to each added item with vba

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):

[color=red][b]Public Sub AcadDocument_ObjectAdded(ByVal Elem As Object)[/b][/color]
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?