Match Dynamic Property Values IF Parameter Name =

[wroebuck]

As with all coding...I'm so close but yet so far...

So what I am after is any help getting the code below to run correctly. The user is prompted to select a dynamic block with or without attributes. The code would create a matrix of all the dynamic property names, values & if attributes exist they too are stored. The user is then prompted to select other AutoCAD entities to match. If they are blocks and have dynamic properties that are named the same it would define the stored value. Same with the attributes. Here's the kicker, they do not need to be the same block name. All I care about is the parameter names. I have attached my code & test blocks...



Sub MatchDBlockProperties()

Dim Prop As Variant
Dim Prop2 As Variant
Dim V As Variant
Dim V2 As Variant
Dim i As Long
Dim blkRef As AcadBlockReference
Dim blkRef2 As AcadBlockReference
Dim oBkRef As IAcadBlockReference '2
Dim oBkRef2 As IAcadBlockReference '2
Dim MastchVS As AcadSelectionSet
Dim Vvalue As String
Dim V2value As String
Dim varAttributes As Variant
Dim varAttributes2 As Variant
Dim Blockname As String
Dim Blockname2 As String

Tag

On Error Resume Next
ThisDrawing.SelectionSets.Item("MastchVS1").Delete
Set MastchVS = ThisDrawing.SelectionSets.Add("MastchVS1")
On Error GoTo exitsub

ThisDrawing.Utility.GetEntity blkRef, pt, "Select Dynamic Block to reference: "

On Error GoTo exitsub
If blkRef.ObjectName = "AcDbBlockReference" Then
Set oBkRef = blkRef
If oBkRef.IsDynamicBlock = True Then
Blockname = oBkRef.EffectiveName
V = oBkRef.GetDynamicBlockProperties
If oBkRef.HasAttributes Then
varAttributes = oBkRef.GetAttributes
End If
'Next
End If
End If

blkRef.Update
ThisDrawing.Utility.Prompt vbCrLf & vbCr
ThisDrawing.Utility.Prompt vbCrLf & "Dynamic Block(s) required to match, Please" & vbCrLf '''added
MastchVS.SelectOnScreen

V = oBkRef.GetDynamicBlockProperties
For Each blkRef2 In MastchVS
If blkRef2.ObjectName = "AcDbBlockReference" Then
Set oBkRef2 = blkRef2
If oBkRef2.IsDynamicBlock = True Then
Blockname2 = oBkRef2.EffectiveName
'If Blockname2 = Blockname Then ******** REMOVED NAME REQUIREMENT TO ALLOW MATCHING OF JUST DYNAMIC PROPERTIES 4/30/15**********
V2 = oBkRef2.GetDynamicBlockProperties
For i = LBound(V) To UBound(V)
Set oDynProp2 = V2(i)
'If Prop2 <> "Origin" Then
If V2(i).PropertyName = V(i).PropertyName Then
V2(i).Value = V(i).Value
End If
Next i
If oBkRef.HasAttributes Then
varAttributes2 = oBkRef2.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
varAttributes2(i).TextString = varAttributes(i).TextString
Next
End If
'End If
End If
End If
Next
ThisDrawing.Regen acAllViewports
On Error Resume Next
ThisDrawing.SelectionSets.Item("MastchVS1").Delete
Exit Sub
exitsub:
On Error Resume Next
ThisDrawing.SelectionSets.Item("MastchVS1").Delete
End Sub

[wroebuck]

Here is the test file...

[wroebuck]

Any tid bit would be helpful!