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
