«Потерянные блоки»

Option Explicit
Sub RenameGhosts()
     Dim oEnt As AcadEntity, objCopy() As Object, _
         oBlock As AcadBlock, oblkRef As AcadBlockReference, _
         varPt, bName As String, oldName As String, _
         insPt As Variant, oItem As Object, _
         iCnt As Integer, jCnt As Integer
     On Error GoTo Err_Control
     ThisDrawing.Utility.GetEntity oEnt, varPt, vbCrLf & "Select unnamed (anonymous) block "
     If oEnt Is Nothing Then Exit Sub
     If TypeOf oEnt Is AcadBlockReference Then
          Set oblkRef = oEnt
          MsgBox oblkRef.Name
     End If
     oldName = oblkRef.Name
     If Left$(oldName, 2) <> "*U" Then Exit Sub
     iCnt = 0
     Set oBlock = ThisDrawing.Blocks.Item(oldName)
     insPt = oBlock.Origin
     jCnt = oBlock.Count - 1
     ReDim objCopy(jCnt) As Object
     For Each oItem In oBlock
          Set objCopy(iCnt) = oItem
          iCnt = iCnt + 1
     Next oItem
     bName = InputBox("Enter new name for unnamed block: ", "BLOCK NAME")
     Set oBlock = ThisDrawing.Blocks.Add(insPt, bName)
     ThisDrawing.CopyObjects objCopy, oBlock
     Dim oSset As AcadSelectionSet, _
         fcode(0) As Integer, _
         fData(0) As Variant, _
         dxfcode, dxfdata, _
         setName As String
     fcode(0) = 0
     fData(0) = "INSERT"
     dxfcode = fcode
     dxfdata = fData
     setName = "$Anonym$"
     For iCnt = 0 To ThisDrawing.SelectionSets.Count - 1
          If ThisDrawing.SelectionSets.Item(iCnt).Name = setName Then
               ThisDrawing.SelectionSets.Item(iCnt).Delete
               Exit For
          End If
     Next iCnt
     ZoomExtents
     Set oSset = ThisDrawing.SelectionSets.Add(setName)
     oSset.Select acSelectionSetAll, , , dxfcode, dxfdata
     If oSset.Count = 0 Then
          MsgBox "Empty set"
          Exit Sub
     End If
     Dim dblXscl As Double, dblYscl As Double, _
         dblZscl As Double, dblRot As Double, _
         layName As String
     iCnt = 0
     For Each oEnt In oSset
          Set oblkRef = oEnt
          If oblkRef.Name = oldName Then
               insPt = oblkRef.InsertionPoint
               dblXscl = oblkRef.XScaleFactor
               dblYscl = oblkRef.YScaleFactor
               dblZscl = oblkRef.ZScaleFactor
               dblRot = oblkRef.Rotation
               layName = oblkRef.Layer
               oblkRef.Delete
               Set oblkRef = _
               ThisDrawing.ActiveLayout.Block.InsertBlock(insPt, bName, dblXscl, dblYscl, dblZscl, dblRot)
               oblkRef.Layer = layName
               oblkRef.Update
               iCnt = iCnt + 1
          End If
     Next
     MsgBox "There are renamed " & iCnt & " blocks " & Chr(34) & oldName & Chr(34)
     ThisDrawing.Regen acAllViewports
     Exit Sub
Err_Control:
     If Err Then MsgBox Err.Description
End Sub