Redefine block vba creates errors in drawings

[GilesPhillips]

I have some code that I'm using as a part of a larger project to automate some (tedious) tasks. This code will redefine a block of a given name from a block in a specified file - useful for updating parts when a spec or supplier changes for example.

The function has existed for many years, and got rewritten to accommodate dynamic blocks with visibility states. It works in essence by renaming the target block, making a note of the attributes, dynamic properties and other uniquenesses and then importing the updated block and inserting it with the properties and suchlike of the old ones - then the renamed old blocks are deleted,  code below:

Function UpdateBlock(subjdwg As AcadDocument, SourceDrawing As String, Blockname As String) As String

' This sub will update the block references in the target files to those in a specified file.
' Files and blocks are specified in the BlockSelectForm
' updated to work with dynamic blocks
' updatd again to work with non dynamic and dyanmic blocks together

Dim Acadver As String
Dim DestBlock As AcadBlock
Dim HostBlockDef As AcadBlock
Dim DynB As Boolean
Dim FirstFound As Boolean
Dim Layout As AcadLayout
Dim Ent As AcadEntity
Dim BlkRef As AcadBlockReference
Dim BlkList() As Variant
Dim DynBlkList() As Variant
Dim DyBlkProps As Variant
Dim NoOfProps As Integer
Dim PropCnt As Integer
Dim BlkProp As AcadDynamicBlockReferenceProperty
Dim ObjDBX As Object
Dim TempSrcDwg As String
Dim srcBlock As AcadBlock
Dim SrcModSp As AcadBlock
Dim CopyArray() As Object
Dim InsPt(0 To 2) As Double
Dim OldDestBlockName As String
Dim TemplateBlk As AcadBlockReference
Dim BlkCnt As Integer
Dim BlkOwner As AcadBlock
Dim ReplBlk As AcadBlockReference
Dim NoOfNewProps As Integer
Dim NewPropCnt As Integer
Dim ArrayPos As Integer
Dim OrigAtts As Variant
Dim NewAtts As Variant
Dim N As Integer
Dim Report As String
Dim ProptoRead As AcadDynamicBlockReferenceProperty
Dim AllowVal As Integer
Dim pos As Integer

InsPt(0) = 0
InsPt(1) = 0
InsPt(2) = 0
Acadver = Mid(ThisDrawing.GetVariable("acadver"), 1, 2)

On Error GoTo LocalBlockNotFound
Set DestBlock = subjdwg.Blocks.Item(Blockname) 'block to be updated in current acad file
If DestBlock.IsDynamicBlock Then
    DynB = True
End If

On Error GoTo GeneralError
pos = 0

For Each HostBlockDef In subjdwg.Blocks
    For Each Ent In HostBlockDef
    pos = pos + 1
        If Ent.ObjectName = "AcDbBlockReference" Then
            
            Set BlkRef = Ent
            If UCase(BlkRef.EffectiveName) = UCase(Blockname) Then
                If DynB Then
                    DyBlkProps = BlkRef.GetDynamicBlockProperties
                    NoOfProps = UBound(DyBlkProps) + 1
                    If FirstFound = False Then
                        ReDim BlkList(0 To (NoOfProps), 0)
                        FirstFound = True
                    End If
                Else
                    If FirstFound = False Then
                        ReDim BlkList(0 To 1, 0)
                        FirstFound = True
                    End If
                End If 'dynb
                Set BlkList(0, UBound(BlkList, 2)) = BlkRef
                If DynB Then
                    For PropCnt = 1 To NoOfProps
                        Set BlkProp = DyBlkProps(PropCnt - 1)
                        Set BlkList(PropCnt, UBound(BlkList, 2)) = BlkProp
                    Next PropCnt
                    ReDim Preserve BlkList(0 To (NoOfProps), UBound(BlkList, 2) + 1)
                Else
                    ReDim Preserve BlkList(0 To 1, UBound(BlkList, 2) + 1)
                End If
                    
                    
            
            End If 'blockname
        End If
    Next Ent
Next HostBlockDef

On Error GoTo 0
Set ObjDBX = ThisDrawing.Application.GetInterfaceObject("objectdbx.axdbdocument." & Acadver)
On Error GoTo OpenFileFail
'copy source to temp location first
TempSrcDwg = copyfiletotemp(pathname(SourceDrawing), foldername(SourceDrawing))
'open (temp) source file to read block
ObjDBX.Open TempSrcDwg

On Error GoTo SourceBlockNotFound
Set srcBlock = ObjDBX.Blocks.Item(Blockname) 'block used to update current block
On Error GoTo GeneralError

Set SrcModSp = ObjDBX.Blocks.Item("*Model_Space")
ReDim CopyArray(0)
Set CopyArray(0) = SrcModSp.InsertBlock(InsPt, Blockname, 1, 1, 1, 0)

'rename destination block -will be deleted
OldDestBlockName = DestBlock.name
DestBlock.name = DestBlock.name & "-tmp!"

'copy array of 1 block into modelspace
'this is just to bring in the definition, it'll be deleted later
ObjDBX.CopyObjects CopyArray, subjdwg.ModelSpace
'assigns this inserted block to a variable - easier to delete later
Set TemplateBlk = subjdwg.ModelSpace.Item(subjdwg.ModelSpace.Count - 1) 'it is last item in modelspace


'go through list of blocks in block list and replace blocks then dynamic properties to what they were before update
For BlkCnt = 0 To UBound(BlkList, 2) - 1
    Set BlkRef = BlkList(0, BlkCnt) 'set blockref to be updated (reused)
    Set BlkOwner = subjdwg.ObjectIdToObject(BlkRef.OwnerID)
    Set ReplBlk = BlkOwner.InsertBlock(BlkRef.InsertionPoint, TemplateBlk.name, BlkRef.XScaleFactor, BlkRef.YScaleFactor, BlkRef.ZScaleFactor, BlkRef.Rotation)
    'ReplBlk.InsUnits = BlkRef.InsUnits
    ReplBlk.Layer = BlkRef.Layer
    ReplBlk.Linetype = BlkRef.Linetype
    ReplBlk.LinetypeScale = BlkRef.LinetypeScale
    ReplBlk.Lineweight = BlkRef.Lineweight
    ReplBlk.PlotStyleName = BlkRef.PlotStyleName
    ReplBlk.TrueColor = BlkRef.TrueColor
    ReplBlk.Visible = BlkRef.Visible
    
    If ReplBlk.IsDynamicBlock And DynB Then
        'synchronise dynamic properties only if both original and replacement blocks are dynamic
        'assume default for dynamic will do if original isn't
        DyBlkProps = ReplBlk.GetDynamicBlockProperties
        NoOfNewProps = UBound(DyBlkProps) + 1 ' number of props may have changed
        For NewPropCnt = 1 To NoOfNewProps 'loop through each dynamic property in updated block
            Set BlkProp = DyBlkProps(NewPropCnt - 1)
            For PropCnt = 1 To (UBound(BlkList, 1)) ' loop through list of stored properties
                Set ProptoRead = BlkList(PropCnt, BlkCnt)
                If BlkProp.PropertyName = ProptoRead.PropertyName Then ' see what matches property name
                        If UBound(BlkProp.AllowedValues) <= UBound(ProptoRead.AllowedValues) Then
                            For AllowVal = 0 To UBound(BlkProp.AllowedValues)
                                ProptoRead.AllowedValues(AllowVal) = BlkProp.AllowedValues(AllowVal)
                            Next AllowVal
                            Else
                            'number of allowed values of this property are different..
                        End If
                        BlkProp.Value = ProptoRead.Value
                        If BlkProp.Value <> ProptoRead.Value Then
                        'Failed to set value, possibly due to conflicting allowed values), report it and move on..
                            Report = "failed to set value " & ProptoRead.Value & " for dynamic property " & ProptoRead.PropertyName & " in block " & Blockname & vbCr
                        End If
                End If
            Next
        Next
        'now update attributes
    End If 'isdynamic
    If BlkRef.HasAttributes And ReplBlk.HasAttributes Then
        'now copy attributes across
        OrigAtts = BlkRef.GetAttributes
        NewAtts = ReplBlk.GetAttributes
        For ArrayPos = 0 To UBound(OrigAtts)
            For N = 0 To UBound(NewAtts)
                If NewAtts(N).TagString = OrigAtts(ArrayPos).TagString Then
                    NewAtts(N).TextString = OrigAtts(ArrayPos).TextString
                    NewAtts(N).StyleName = OrigAtts(ArrayPos).StyleName
                    NewAtts(N).Height = OrigAtts(ArrayPos).Height
                    NewAtts(N).ScaleFactor = OrigAtts(ArrayPos).ScaleFactor
                    NewAtts(N).Alignment = OrigAtts(ArrayPos).Alignment
                    NewAtts(N).Rotation = OrigAtts(ArrayPos).Rotation
                End If
            Next N
        Next ArrayPos
    End If
    'delete old block reference
    BlkRef.Delete
Next BlkCnt

'remove imported block template
TemplateBlk.Delete
'delete old block reference
DestBlock.Delete

'synch attributes
subjdwg.SendCommand "Attsync" & vbCr & "n" & vbCr & Blockname & vbCr
subjdwg.Regen acActiveViewport
UpdateBlock = Report & Blockname & " Block updated."


Set ObjDBX = Nothing
removefilefromtemp (TempSrcDwg)

Exit Function

OpenFileFail:
UpdateBlock = "-2 Cannot open Source File " & SourceDrawing & ", is it open/locked?"
Set ObjDBX = Nothing
Exit Function

LocalBlockNotFound:
UpdateBlock = "0 " & Blockname & " not in this file"
Set ObjDBX = Nothing
Exit Function

SourceBlockNotFound:
UpdateBlock = "-1 Cannot update block " & Blockname & ", is it not in the source file?"
Set ObjDBX = Nothing
Exit Function

GeneralError:
UpdateBlock = "-2 Code error in " & Err.Source & " with block " & Blockname & " " & Err.Description
Set ObjDBX = Nothing
Exit Function

End Function

the problem is that I'm now getting errors in the drawings, which require manual recovery:

Validating objects in the handle table.
Valid objects 19725  Invalid objects 0
Validating objects completed.

    Salvaged database from drawing.

Reading handle 22034 object type AcDbDynamicBlockPurgePreventer
        Error 13 (eUnknownHandle)                       Object discarded
Reading handle 2246B object type AcDbBlockRepresentationData
        Error 13 (eUnknownHandle)                       Object discarded
Reading handle 2267F object type AcDbBlockRepresentationData
        Error 13 (eUnknownHandle)                       Object discarded
Reading handle 22893 object type AcDbBlockRepresentationData
        Error 13 (eUnknownHandle)                       Object discarded
Reading handle 22AA7 object type AcDbBlockRepresentationData
        Error 13 (eUnknownHandle)                       Object discarded

Auditing Header

Auditing Tables

Auditing Entities Pass 1

Pass 1 10200   objects auditedAcDbBlockTableRecord: "*U99"
                     XData Handle Unknown               Null
Pass 1 12100   objects auditedAcDbLine(28661)      XData Handle Unknown               Null
AcDbPolyline(28663)  XData Handle Unknown               Null
AcDbPolyline(28665)  XData Handle Unknown               Null
AcDbPolyline(28666)  XData Handle Unknown               Null
AcDbPolyline(28667)  XData Handle Unknown               Null
AcDbBlockReference(2866C)
                     XData Handle Unknown               Null
Pass 1 13600   objects auditedAcDbLine(28FC7)      XData Handle Unknown               Null
AcDbPolyline(28FC9)  XData Handle Unknown               Null
AcDbPolyline(28FCB)  XData Handle Unknown               Null
AcDbPolyline(28FCC)  XData Handle Unknown               Null
AcDbPolyline(28FCD)  XData Handle Unknown               Null
AcDbBlockReference(28FD2)
                     XData Handle Unknown               Null
Pass 1 19800   objects audited
Auditing Entities Pass 2

Pass 2 19800   objects audited
Auditing Blocks

 257     Blocks audited

Auditing AcDsRecords

Total errors found 13 fixed 13

Erased 5 objects

I'm guessing that simply deleting the 'old' blocks isn't right (line 182 of my code above), as there's now xdata that's attached to it, but how do I find the xdata -it's not something I've really played with..

Is there a better way to do this rather than my somewhat circuitous route that kinda works, but isn't without issues?

any thoughts and advice appreciated..

thanks

G

[Ed__Jobe]

Your logic is hard to follow. It tries to do too many things. Break your goal into smaller tasks/subs/functions. Test the smaller tasks separately. This process is called refactoring.

You have too many GoTo statements. It's better to use If..Then or Select...Case logic than jump all over the place. See this thread for some examples of error handling. I like to have only one error handling scheme per sub. If you need something different, its a sign that you should put the logic in a separate function.

You should get an AxDbDocument like this:

Set oDbxDoc = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument." & Left(AcadApplication.Version, 2))
oDbxDoc.Open (strPath)

You don't really need an error handler for this function. You should have validated the filepath previously. You can use FileSystemObject.FileExists(strPath) to check it.