Блоки с одинаковым именем (Страница 2 из 2)

Option Explicit
Sub TestRenameBlocks()
     Dim handleArr() As String
     Dim oSset As AcadSelectionSet
     Dim oEnt As AcadEntity
     Dim pickPt As Variant
     Dim blkRef As AcadBlockReference
     Dim setName As String
     Dim dxfcode(0 To 1) As Integer
     Dim dxfdata(0 To 1) As Variant
     dxfcode(0) = 0
     dxfdata(0) = "INSERT"
     dxfcode(1) = 2
     Dim i As Integer
     Dim bName As String
     bName = ""
     Do
      ThisDrawing.Utility.GetEntity oEnt, pickPt, "Выбрать единичный блок:"
      If TypeOf oEnt Is AcadBlockReference Then
      Set blkRef = oEnt
      bName = blkRef.EffectiveName
      Else
      bName = InputBox(vbCr & vbCr & "Введи имя блока:", "Переименование блоков")
     dxfdata(1) = bName
     End If
     Loop Until bName <> ""
     
    'MsgBox bName

     dxfdata(1) = bName

     setName = "$Blocks$"
    
          ' удостоверяемся, что именованный выбор не существует

          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
               ' создаем новый выбор
          Set oSset = .Add(setName)
          End With
     
     oSset.SelectOnScreen dxfcode, dxfdata
     '
     If oSset.Count = 0 Then
          ThisDrawing.Utility.prompt (vbCr & "Блок " & bName & " не существует в рисунке")
          Exit Sub
     Else
          ThisDrawing.Utility.prompt (vbCr & "Выбрано: " & oSset.Count & " блоков")
     End If
     
     Dim n
     ReDim handleArr(0 To oSset.Count - 1)
     For Each oEnt In oSset
     
     Set blkRef = oEnt
     'сохраняем хэндлы всех выбранных блоков в массив:
     handleArr(n) = blkRef.Handle
     'конвертируем вставку блока в анонимный блок
     blkRef.ConvertToAnonymousBlock
     n = n + 1
     Next
     ' переименовываем блоки по одному или единичный блок если один
     bName = ""
     For n = LBound(handleArr) To UBound(handleArr)
     Dim oObj  As AcadObject
     Set oObj = ThisDrawing.HandleToObject(handleArr(n))
     Set blkRef = oObj
     bName = InputBox(vbCr & vbCr & "Введи новое имя блока:", "Переименование блоков", "Предыдущее имя = " & bName)
     On Error Resume Next
     blkRef.ConvertToStaticBlock (bName)
     If Err Then
     Err.Clear
    ''MsgBox "Блок с именем " & bName & "существует, выход..."
     End If
     
     On Error GoTo 0
     blkRef.Update
     Next
     
End Sub

Sub TestRenameBlocks()
     Dim handleArr() As String
     Dim oSset As AcadSelectionSet
     Dim oEnt As AcadEntity
     Dim pickPt As Variant
     Dim blkRef As AcadBlockReference
     Dim setName As String
     Dim dxfcode(0 To 1) As Integer
     Dim dxfdata(0 To 1) As Variant
     
     dxfcode(0) = 0
     dxfdata(0) = "INSERT"
     dxfcode(1) = 2
     
     Dim i As Integer
     Dim n As Integer
     Dim bName As String
     bName = ""
     
     n = 0
     For Each oEnt In ThisDrawing.ModelSpace
         If TypeOf oEnt Is AcadBlockReference Then
            If oEnt.EffectiveName Like "*ÌÏÂ*" Then
               n = n + 1
            End If
         End If
     Next
     
     ReDim handleArr(0 To n - 1)
     n = 0
     For Each oEnt In ThisDrawing.ModelSpace
         If TypeOf oEnt Is AcadBlockReference Then
            If oEnt.EffectiveName Like "*МПВ*" Then
               Set blkRef = oEnt
               'сохраняем хэндлы всех выбранных блоков в массив: 
               handleArr(n) = blkRef.Handle
                'конвертируем вставку блока в анонимный блок 
               blkRef.ConvertToAnonymousBlock
               n = n + 1
            End If
         End If
     Next
     
     ' переименовываем блоки 
     bName = ""
     For n = LBound(handleArr) To UBound(handleArr)
        Dim oObj  As AcadObject
        Set oObj = ThisDrawing.HandleToObject(handleArr(n))
        Set blkRef = oObj
        bName = blkRef.EffectiveName
        bName = "МПВ"
        On Error Resume Next
        blkRef.ConvertToStaticBlock (bName)
        If Err Then
           Err.Clear
           MsgBox "Блок с именем " & bName & "  существует, выход..." 
        End If
        On Error GoTo 0
        
        blkRef.Update
        Set oObj = ThisDrawing.HandleToObject(handleArr(n))
        Set blkRef = oObj
        bName = blkRef.EffectiveName
     Next
    
End Sub