Option Explicit
'@=========================================@'
'@ Функция проверки строки на возможность @'
'@ использования ее в качестве имени блока @'
'@ Если эта строка уже используется в @'
'@ качестве имени блока, то функция сгене- @'
'@ рирует на базе заданного новое имя @'
'@=========================================@'
Public Function BlockNameIncrement(strName As String) As String
Dim objBlocks As AcadBlocks
Dim objBlock As AcadBlock
Dim strValue As String
Dim intCnt As Integer
Dim blnFound As Boolean
On Error GoTo Err_Control
Set objBlocks = ThisDrawing.Blocks
strValue = strName
Do
For Each objBlock In objBlocks
If objBlock.name = strValue Then
blnFound = True
intCnt = intCnt + 1
strValue = strName & intCnt
Exit For
Else
blnFound = False
End If
Next objBlock
Loop Until Not blnFound
BlockNameIncrement = strValue
Exit_Here:
Exit Function
Err_Control:
MsgBox Err.Description
End Function
'@=========================================@'
'@ Функция для создания блока из набора @'
'@ объектов objSelSet, с именем strName и @'
'@ с базовой точкой varPnt @'
'@=========================================@'
Public Function BlockSelSet(objSelSet As AcadSelectionSet, _
varPnt As Variant, strName As String) As AcadBlock
Dim objBlks As AcadBlocks
Dim objTemp As AcadBlock
Dim objArray() As AcadEntity
Dim intCnt As Integer
Set objBlks = ThisDrawing.Blocks
For intCnt = 0 To objSelSet.Count - 1
ReDim Preserve objArray(intCnt)
Set objArray(intCnt) = objSelSet(intCnt)
Next intCnt
Set objTemp = objBlks.Add(varPnt, strName)
ThisDrawing.CopyObjects objArray, objTemp
Set BlockSelSet = objTemp
Set objBlks = Nothing
Set objTemp = Nothing
End Function
Public Sub TEST_BlockSelSet()
Dim strBlkName As String
Dim varPnt As Variant
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim objNewBlock As AcadBlock
On Error Resume Next
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.name = "SelSetForBlock" Then
objSelSet.Delete
Exit For
End If
Next
Set objSelSet = ThisDrawing.SelectionSets.Add("SelSetForBlock")
objSelSet.SelectOnScreen
With ThisDrawing.Utility
varPnt = .GetPoint(, vbCr & _
"Укажите базовую точку блока: ")
strBlkName = .GetString(False, vbCr & _
"Введите имя создаваемого блока: ")
End With
Set objNewBlock = BlockSelSet(objSelSet, _
varPnt, BlockNameIncrement(strBlkName))
End Sub
