5 Minutes Of Fame

I recently had some of my code posted on Cadalyst. I am posting it here for those of you who may need to copy attributes from one block to another block. We do this semi-often with various title blocks from customers and it comes in handy for "copying" information around. Enjoy.

Public Sub UserCopyAttsFromBlkToAnotherBlk()
'------------------------------------------------------------------------------
'user selects block and then selects attributed block to match to
'
'------------------------------------------------------------------------------
Dim vAtts As Variant
Dim vAtts2 As Variant
Dim sPrompt As String
'''''''''''''''''''''''''''''''''''''''
On Error GoTo ErrHandler

sPrompt = "Select Source Attributed Block: "
vAtts = UserGetBlockWithAtts(sPrompt).GetAttributes

sPrompt = "Select Destination Attributed Block: "
vAtts2 = UserGetBlockWithAtts(sPrompt).GetAttributes

Call CopySameAttsFromBlkToBlk(vAtts, vAtts2)

ErrHandler:
Select Case Err.Number
Case 0
Case Else
Err.Clear
End Select
End Sub

Public Function UserGetBlockWithAtts(Optional sPrompt As String = _
"Select Attributed Block: ") As AcadBlockReference
'------------------------------------------------------------------------------
'
'
'------------------------------------------------------------------------------
Dim acObj As Object
Dim vPickPt As Variant
Dim sAtt As String
'''''''''''''''''''''''''''''''''''''''
On Error GoTo NOT_ENTITY

TRY_AGAIN:
ThisDrawing.Utility.GetEntity acObj, vPickPt, sPrompt
If acObj.ObjectName <> "AcDbBlockReference" Then
GoTo NOT_ENTITY
End If

If acObj.HasAttributes Then
Set UserGetBlockWithAtts = acObj
Else
MsgBox "This Block has no Attributes"
End If
Exit Function

NOT_ENTITY:
'If you click on space or do not select an entity, this error will be generated
If MsgBox("You have not selected a block with attributes.", vbOKCancel) = vbOK Then
Resume TRY_AGAIN
End If
End Function


Public Sub CopySameAttsFromBlkToBlk(ByVal vAtts1 As Variant, _
ByRef vAtts2 As Variant)
'------------------------------------------------------------------------------
'
'
'------------------------------------------------------------------------------
Dim l As Long
Dim m As Long
'''''''''''''''''''''''''''''''''''''''
For m = LBound(vAtts1) To UBound(vAtts1)
For l = LBound(vAtts2) To UBound(vAtts2)
If vAtts1(m).TagString = vAtts2(l).TagString Then
vAtts2(l).TextString = vAtts1(m).TextString
End If
Next l
Next m
End Sub