[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?