Here is another way
[code]
Option Explicit
Sub ChangeDupes()
Dim blkRef As AcadBlockReference
Dim attObj As AcadAttributeReference
Dim varPt As Variant
Dim blkDef As AcadBlock
Dim itmObj As AcadObject
Dim blkName, attVal As String
Dim aTag, sTag, sPrompt As String
Dim i, j As Integer
Dim tmpArr(1) As String
Dim dataColl As New Collection
On Error Resume Next
'@' get the block reference
ThisDrawing.Utility.GetEntity blkRef, varPt, "Select block reference"
If blkRef Is Nothing Then
MsgBox "Nothing selected" & vbCrLf & "try again"
Exit Sub
End If
blkName = blkRef.Name
Set blkDef = ThisDrawing.Blocks.Item(blkName)
aTag = UCase(InputBox("Enter a tag name" & vbCrLf & _
"(case-non-sensitive) : "))
On Error GoTo ErrCatch:
'@' fill collection with promps and tags
For Each itmObj In blkDef
If itmObj.ObjectName = "AcDbAttributeDefinition" Then
If itmObj.TagString = aTag Then
sPrompt = itmObj.PromptString
sTag = itmObj.TagString
tmpArr(0) = sPrompt
tmpArr(1) = sTag
dataColl.Add tmpArr
Erase tmpArr
End If
End If
Next
'@' change attribute values
Dim attArr As Variant
Dim colArr As Variant
attArr = blkRef.GetAttributes
j = 1
For i = 0 To UBound(attArr)
Set attObj = attArr(i)
If attObj.TagString = aTag Then
colArr = dataColl.Item(j)
'@' Loop trough collection
Select Case colArr(0)
Case "First prompt"
attObj.TextString = "Value #1"
Case "Second prompt"
attObj.TextString = "Value #2"
Case "Third prompt"
attObj.TextString = "Value #3"
Case "Fourth prompt"
attObj.TextString = "Value #4"
End Select
j = j + 1
End If
Next
'@' release collection
Dim unitArr As Variant
For Each unitArr In dataColl
dataColl.Remove 1
Next
Set dataColl = Nothing
ErrCatch:
MsgBox Err.Description
End Sub
[/code]
Fatty
~'J'~
