Not sure about if this helps, this one is similar on your task
<CommandMethod("BlockReplaceTest", "breplace", CommandFlags.Session Or CommandFlags.Modal Or CommandFlags.UsePickSet Or CommandFlags.Redraw)> _
Public Sub TestBlockReplaceByName()
' objects initializing
Dim doc As Document = acApp.DocumentManager.MdiActiveDocument
Dim ed As Editor = doc.Editor
Dim db As Database = doc.Database
Try
Using doc.LockDocument()
Using tr As Transaction = db.TransactionManager.StartTransaction()
Dim psto As New PromptStringOptions(vbLf & "Enter a replacement block name: ")
psto.AllowSpaces = True
psto.DefaultValue = "MyBlock" 'old block
Dim stres As PromptResult
stres = ed.GetString(psto)
If stres.Status <> PromptStatus.OK Then
Return
End If
Dim oldblock As String = stres.StringResult
ed.WriteMessage(vbLf & "Text Entered" & vbTab & "{0}", oldblock)
psto = New PromptStringOptions(vbLf & "Enter a block name to be replaced: ")
psto.AllowSpaces = True
psto.DefaultValue = "NewBlock" 'new block
stres = ed.GetString(psto)
If stres.Status <> PromptStatus.OK Then
Return
End If
Dim newblock As String = stres.StringResult
Dim bt As BlockTable = TryCast(tr.GetObject(db.BlockTableId, OpenMode.ForRead), BlockTable)
If Not bt.Has(newblock) Then
Return
End If
Dim newblkId As ObjectId = bt(newblock)
acApp.SetSystemVariable("nomutt", 1)
Dim tvs As TypedValue() = {New TypedValue(0, "insert"), New TypedValue(2, oldblock)}
Dim filt As New SelectionFilter(tvs)
Dim pso As New PromptSelectionOptions()
pso.MessageForRemoval = "You must select the blocks only"
pso.MessageForAdding = vbLf & "Select replacement blocks: "
AddHandler ed.SelectionAdded, AddressOf ed_SelectionAdded
Dim res As PromptSelectionResult = ed.GetSelection(pso, filt)
If res.Status <> PromptStatus.OK Then
Return
End If
Dim btr As BlockTableRecord = TryCast(tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite), BlockTableRecord)
Dim sset As SelectionSet = res.Value
For Each obj As SelectedObject In sset
Dim ent As Entity = TryCast(DirectCast(obj.ObjectId.GetObject(OpenMode.ForRead), Entity), Entity)
Dim oldblk As BlockReference = TryCast(ent, BlockReference)
Dim ip As Point3d = oldblk.Position
Dim scl As Scale3d = oldblk.ScaleFactors
Dim rot As Double = oldblk.Rotation
Dim newblk As New BlockReference(ip, newblkId)
newblk.SetPropertiesFrom(ent)
newblk.Rotation = rot
newblk.ScaleFactors = scl
btr.AppendEntity(newblk)
tr.AddNewlyCreatedDBObject(newblk, True)
ApplyAttributes(db, tr, newblk)
oldblk.UpgradeOpen()
oldblk.Erase()
oldblk.Dispose()
Next
tr.Commit()
End Using
End Using
Catch ex As System.Exception
ed.WriteMessage(ex.Message & vbLf & ex.StackTrace)
Finally
acApp.SetSystemVariable("nomutt", 0)
RemoveHandler ed.SelectionAdded, AddressOf ed_SelectionAdded
End Try
End Sub
Private Sub ed_SelectionAdded(sender As Object, e As SelectionAddedEventArgs)
' you may want to add some action here
DirectCast(sender, Editor).WriteMessage(vbLf & vbTab & "{0} blocks to selection added", e.AddedObjects.Count)
End Sub
Public Sub ApplyAttributes(db As Database, tr As Transaction, bref As BlockReference)
Dim btrec As BlockTableRecord = TryCast(tr.GetObject(bref.BlockTableRecord, OpenMode.ForRead), BlockTableRecord)
If btrec.HasAttributeDefinitions Then
Dim atcoll As Autodesk.AutoCAD.DatabaseServices.AttributeCollection = bref.AttributeCollection
For Each subid As ObjectId In btrec
Dim ent As Entity = DirectCast(subid.GetObject(OpenMode.ForRead), Entity)
Dim attDef As AttributeDefinition = TryCast(ent, AttributeDefinition)
If attDef IsNot Nothing Then
Dim attRef As New AttributeReference()
attRef.SetDatabaseDefaults()
'optional
attRef.SetAttributeFromBlock(attDef, bref.BlockTransform)
attRef.Position = attDef.Position.TransformBy(bref.BlockTransform)
attRef.Justify = attDef.Justify
'must be added all other properties for right position, eg. alignment modes etc
attRef.Tag = attDef.Tag
attRef.AdjustAlignment(db)
atcoll.AppendAttribute(attRef)
tr.AddNewlyCreatedDBObject(attRef, True)
End If
Next
End If
End Sub
~'J'~
_____________________________________
C6309D9E0751D165D0934D0621DFF27919
Утвердить в качестве решения и 
Баллы
