Here's a routine that pretty much does what you describe. We had a project with thousands of room targets already in place when someone decided we had to add one more field for a finish code. This program reads all the targets on a drawing and stores the attributes in memory, then deletes the targets, purges and puts back a new target with the additional field and the original attribute information. This sub is called from a main procedure that loads drawings one at a time from a list, calls the replace routine, saves the file then loops until done.
Code:
Option Base 1
Sub ReplaceRmTar()
Dim F As Integer
Dim FileName As String
Dim FileList As String
FileList = "w:\a\data\filelist.txt"
F = FreeFile()
Open FileList For Input As #F
Do While Not EOF(F)
Line Input #F, FileName
Debug.Print FileName
ThisDrawing.Application.Documents.Open FileName
On Error Resume Next 'trap CTB conversion
ZoomAll
If ThisDrawing.ReadOnly = False Then
SetLayer
ReplaceBlock
ThisDrawing.Save
Else
MsgBox FileName & " is READ ONLY"
Debug.Print FileName & " is READ ONLY"
End If
ThisDrawing.Application.ActiveDocument.Close
Loop
Close FileList
Debug.Print "DONE"
End Sub
'================================================================================================
Sub SetLayer()
'================================================================================================
Dim Layer As AcadLayer
On Error Resume Next
Set Layer = ThisDrawing.Layers("A-NOTE-IDEN")
If Layer Is Nothing Then
Set Layer = ThisDrawing.Layers.Add("A-NOTE-IDEN")
Layer.color = acCyan
Layer.Linetype = "CONTINUOUS"
End If
ThisDrawing.ActiveLayer = Layer
ThisDrawing.ActiveLayer.Freeze = False
End Sub
'================================================================================================
Sub ReplaceBlock()
'================================================================================================
Dim Ipt As Variant
Dim RoomName_1 As String
Dim RoomName_2 As String
Dim RoomNumber As String
Dim Finish As String
Dim Attrib As Variant
Dim Tag As Variant
Dim Angle As Double
Dim RmTar As AcadBlockReference
Dim BlkRef As AcadBlockReference
Const ScX As Double = 1#
Const ScY As Double = 1#
Const ScZ As Double = 1#
Dim Target As String
Target = "w:\a\blocks\room_tag.dwg"
Dim Sset As AcadSelectionSet
Set Sset = ThisDrawing.SelectionSets.Add("RoomTarget")
Dim Codes() As Integer
ReDim Codes(2)
Dim CodeValues() As Variant
ReDim CodeValues(2)
Codes(1) = 0
Codes(2) = 2
CodeValues(1) = "INSERT"
CodeValues(2) = "_TARROOM" 'Block name
Sset.Select acSelectionSetAll, , , Codes, CodeValues
If Sset.Count = 0 Then Exit Sub
For Each RmTar In Sset
Ipt = RmTar.InsertionPoint
Ipt(2) = 0#
Angle = RmTar.Rotation
RoomName_1 = ""
RoomName_2 = ""
RoomNumber = ""
Finish = "P000"
For Each Attrib In RmTar.GetAttributes
With Attrib
Select Case .TagString
Case "RMNAM1"
RoomName_1 = Trim(.TextString)
Case "RMNAM2"
RoomName_2 = Trim(.TextString)
Case "RMNUM"
RoomNumber = Trim(.TextString)
End Select
End With
Next Attrib
If RoomName_1 = "" Then RoomName = "----"
If RoomNumber = "" Then RoomNumber = "--"
RmTar.Delete
'insert new block here and set attributes
Set BlkRef = ThisDrawing.ModelSpace.InsertBlock(Ipt, Target, ScX, ScY, ScZ, Angle)
For Each Tag In BlkRef.GetAttributes
Select Case Tag.TagString
Case "RMNAM1"
Tag.TextString = RoomName_1
Case "RMNAM2"
Tag.TextString = RoomName_2
Case "RMNUM"
Tag.TextString = RoomNumber
Case "FINISH"
Tag.TextString = Finish
End Select
Next Tag
BlkRef.Update
Next RmTar
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
ThisDrawing.SelectionSets("RoomTarget").Delete
End Sub