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
 

Option Explicit

Private Sub UserForm_Initialize()
  Dim intCnt As Integer
  
  OptionButton1 = True
  'Replace with first blocks name
  'Здесь Вы можете заменить имена вставляемых блоков
  '"One" и "Two" на любые другие, имеющиеся в чертеже
  OptionButton1.Caption = "One"
  'Replace with second blocks name
  OptionButton2.Caption = "Two"
  CommandButton1.Caption = "Insert"
  CommandButton1.Caption = "Вставить"
  'Label1.Caption = "Scale"
  Label1.Caption = "Масштаб"
  For intCnt = 1 To 10
    ComboBox1.AddItem intCnt
  Next intCnt
  ComboBox1.ListIndex = 0
  'CheckBox1.Caption = "Select Insertion Point"
  CheckBox1.Caption = "Указать точку вставки"
End Sub

Private Sub CommandButton1_Click()
  Dim varInsPnt As Variant
  Dim dblBlkScale As Double
  Dim blnScale As Boolean
  Dim strBlock As String

  If Len(ComboBox1.Text) > 0 Then
    blnScale = True
    dblBlkScale = ComboBox1.Text
  End If
  If OptionButton1 Then
    strBlock = OptionButton1.Caption
  Else
    strBlock = OptionButton2.Caption
  End If
  If CheckBox1 Then
    Me.Hide
    varInsPnt = _
    ThisDrawing.Utility.GetPoint(Prompt:="Insertion Point: ")
    If blnScale Then
      InsertOption strBlock, varInsPnt, dblBlkScale
    Else
      InsertOption strBlock, varInsPnt
    End If
    Me.Show
  Else
    If blnScale Then
      InsertOption strBlock, dblScale:=dblBlkScale
    Else
      InsertOption strBlock
    End If
  End If
End Sub

Public Sub InsertOption(strName As String, _
Optional varPnt As Variant, Optional dblScale As Double = 1)
  Dim objUtil As Object
  If IsMissing(varPnt) Then
    Set objUtil = ThisDrawing.Utility
    objUtil.CreateTypedArray varPnt, vbDouble, 0, 0, 0
  End If
  'I just left rotation at 0
  'В данном примере угол поворота вставляемого блока
  'всегда равен 0 градусов
  If ThisDrawing.ActiveSpace = acModelSpace Then
    ThisDrawing.ModelSpace.InsertBlock varPnt, _
    strName, dblScale, dblScale, dblScale, 0
  Else
    ThisDrawing.PaperSpace.InsertBlock varPnt, _
    strName, dblScale, dblScale, dblScale, 0
  End If
  Application.Update
End Sub
 

Option Explicit

Public Sub TEST_frmBlkInsert()
  frmBlkInsert.Show
End Sub
 

Option Explicit

Private Sub UserForm_Initialize()
  Dim intCnt As Integer
  Dim objAcBlocks As AcadBlocks
  Dim objAcBlock As AcadBlock
  
  Set objAcBlocks = ThisDrawing.Blocks
  ' Заполняем список именами блоков
  For Each objAcBlock In objAcBlocks
    If Not Left(objAcBlock.Name, 1) = "*" Then
    ' Нам не нужны анонимные блоки и блоки типа
    ' *Model_Spase и *Paper_Spase
      ComboBox2.AddItem objAcBlock.Name
    End If
  Next
  ComboBox2.ListIndex = 0
  
  'CommandButton1.Caption = "Insert"
  CommandButton1.Caption = "Вставить"
  'Label1.Caption = "Scale"
  Label1.Caption = "Масштаб"
  For intCnt = 1 To 10
    ComboBox1.AddItem intCnt
  Next intCnt
  ComboBox1.ListIndex = 0
  'CheckBox1.Caption = "Select Insertion Point"
  CheckBox1.Caption = "Указать точку вставки"
End Sub

Private Sub CommandButton1_Click()
  Dim varInsPnt As Variant
  Dim dblBlkScale As Double
  Dim blnScale As Boolean
  Dim strBlock As String
  
  If Len(ComboBox1.Text) > 0 Then
    blnScale = True
    dblBlkScale = ComboBox1.Text
  End If
  If Len(ComboBox2.Text) > 0 Then
    strBlock = ComboBox2.Text
  End If
  If CheckBox1 Then
    Me.Hide
    varInsPnt = _
    ThisDrawing.Utility.GetPoint(Prompt:="Insertion Point: ")
    If blnScale Then
      InsertOption strBlock, varInsPnt, dblBlkScale
    Else
      InsertOption strBlock, varInsPnt
    End If
    Me.Show
  Else
    If blnScale Then
      InsertOption strBlock, dblScale:=dblBlkScale
    Else
      InsertOption strBlock
    End If
  End If
End Sub
 

  Dim strStyleName As String
  Dim objSelSet As AcadSelectionSet
  Dim dblScale As Double

  strStyleName = ThisDrawing.ActiveDimStyle.Name
  intType(0) = 0
  intType(1) = 3
  varData(0) = "DIMENSION"
  varData(1) = strStyleName
  Set objSelSet = ThisDrawing.SelectionSets.Add("dimscaleset")
  objSelSet.Select acSelectionSetAll, filtertype:=intType, _
  filterdata:=varData
  If objSelSet.Count > 0 Then
    dblScale = objSelSet.Item(0).ScaleFactor
  Else
    dblScale = 0
  End If
 

Option Explicit

Public Sub InsertBlocksEX(sBlockName As String, dXScale As Double, _
dYScale As Double, dZScale As Double, dRotation As Double)
  'Dim objPline As AcadPolyline
  Dim objPline As AcadLWPolyline
  Dim objSelSet As AcadSelectionSet
  Dim intVCnt As Integer
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Dim retCoord As Variant
  Dim intCnt As Integer
  Dim varVert As Variant
  Dim varPnt As Variant
  Dim varCord As Variant
  Dim varNext As Variant
  Dim varMid As Variant
  Dim intCrdCnt As Integer

  On Error GoTo Exit_Sub
  intType(0) = 0
  'varData(0) = "POLYLINE"
  varData(0) = "LWPOLYLINE"
  Set objSelSet = vbdPowerSet("inserts")
  objSelSet.SelectOnScreen intType, varData
  For Each objPline In objSelSet
    retCoord = objPline.Coordinates
    intCnt = 1
    For Each varVert In retCoord
      intVCnt = intVCnt + 1
    Next
    'For intCrdCnt = 0 To intVCnt / 3 - 1 'For Poly
    For intCrdCnt = 0 To intVCnt / 2 - 1 'For LWPoly
      varCord = objPline.Coordinate(intCrdCnt)
      ReDim Preserve varCord(2)
      varCord(2) = objPline.Elevation
      If ThisDrawing.ActiveSpace = acModelSpace Then
        ThisDrawing.ModelSpace.InsertBlock varCord, sBlockName, _
        dXScale, dYScale, dZScale, dRotation
      Else
        ThisDrawing.PaperSpace.InsertBlock varCord, sBlockName, _
        dXScale, dYScale, dZScale, dRotation
      End If
    Next
  Next
Exit_Sub:
End Sub

Public Function vbdPowerSet(strName As String) As AcadSelectionSet
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = strName Then
        ThisDrawing.SelectionSets.Item(strName).Delete
        Exit For
      End If
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
  Set vbdPowerSet = objSelSet
End Function

Public Sub TEST_InsertBlocksEX()
  'Be sure to change the block name and info!
  InsertBlocksEX "sh_spot", 1, 1, 1, 0
End Sub
 

Option Explicit

Public Function ExplodeToLayer(strLayerName As String) As Boolean
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objBlk As AcadBlockReference
  Dim varObjs As Variant
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Dim intCnt As Integer
  
  On Error GoTo Err_Control
  
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = "blockem" Then
        ThisDrawing.SelectionSets.Item("blockem").Delete
        Exit For
      End If
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add("blockem")
  intType(0) = 0
  varData(0) = "INSERT"
  objSelSet.SelectOnScreen intType, varData
  For Each objBlk In objSelSet
    varObjs = objBlk.Explode
    For intCnt = LBound(varObjs) To UBound(varObjs)
      varObjs(intCnt).Layer = strLayerName
      If TypeOf varObjs(intCnt) Is AcadAttribute Then
        varObjs(intCnt).Delete
      End If
    Next intCnt
    objBlk.Delete
  Next objBlk
  ExplodeToLayer = True
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function

Public Sub TEST_ ExplodeToLayer()
  If ExplodeToLayer("Layer1") Then
    MsgBox "All blocks exploded to Layer1 and attributes removed"
  Else
    MsgBox "Failed to explode all blocks in selections."
  End If
End Sub
 

Option Explicit

Public Function GetEntityFromBlock(strBlkName As String, _
strType As String, strLayer As String) As AcadEntity
  Dim objBlk As AcadBlock
  Dim objEnt As AcadEntity

  Set objBlk = ThisDrawing.Blocks.Item(strBlkName)
    For Each objEnt In objBlk
      If TypeName(objEnt) = strType Then
        If objEnt.Layer = strLayer Then
          Set GetEntityFromBlock = objEnt
          Exit For
       End If
      End If
    Next objEnt
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function

Public Sub TEST_GetEntityFromBlock()
  Dim objEnt(0) As AcadEntity
  Dim varRet As Variant

  ' Замените имена блока и слоя (test и Layer2)
  ' на любые другие, определенные в чертеже
  Set objEnt(0) = GetEntityFromBlock("test", _
                  "IAcadLWPolyline", "Layer2")
  varRet = ThisDrawing.CopyObjects(objEnt, _
           ThisDrawing.ModelSpace)
End Sub
 

Option Explicit

'Begin Code Block
Public Sub GetBlkRefs(strBlkName As String, objSelSet As AcadSelectionSet)
  Dim objBlk As AcadBlock
  Dim colBlks As AcadBlocks
  Dim objBlkRefs As AcadBlockReference
  Dim varData(0) As Variant
  Dim intData(0) As Integer
  varData(0) = strBlkName
  intData(0) = 2
  objSelSet.Select acSelectionSetAll, , , intData, varData
End Sub

Public Function vbdPowerSet(strName As String) As AcadSelectionSet
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  
  Set objSelCol = ThisDrawing.SelectionSets
  For Each objSelSet In objSelCol
    If objSelSet.Name = strName Then
      ThisDrawing.SelectionSets.Item(strName).Delete
      Exit For
    End If
  Next
  Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
  Set vbdPowerSet = objSelSet
End Function

'Now you can test it
Public Sub TestRefs()
  Dim objSS As AcadSelectionSet
  Dim objblkRef As AcadBlockReference
  
  Set objSS = vbdPowerSet("llama")
  ' Замените имя блока "test" на любое другое,
  ' определенное в теущем чертеже
  ' Хотя бы один блок с таким именем должен быть вставлен
  GetBlkRefs "test", objSS
  For Each objblkRef In objSS
    objSS.Highlight True
  Next objblkRef
End Sub
'End Code Block
 

Option Explicit

'Remember to add a reference to the
'Excel Object type Library

Public Sub SortBlocksWithCount()
  Dim objExcel As Excel.Application
  Dim objSelSet As AcadSelectionSet
  Dim objBlkRef As AcadBlockReference
  Dim objNext As Range
  Dim intRow As Integer
  Dim intBlkCnt As Integer
  Dim intCnt As Integer
  Dim intType(0) As Integer
  Dim varDat(0) As Variant
  Dim blnTop As Boolean
  
  On Error GoTo Err_Control
  'Excel MUST be running for this sample
  Set objExcel = GetObject(, "Excel.Application")
  'clears all cells - make sure there is nothing you
  'want in the active book
  With objExcel
    .Cells.Select
    .Selection.ClearContents
    .Range("A1").Select
    .ActiveCell.FormulaR1C1 = "Block Name"
    .Range("B1").Select
    .ActiveCell.FormulaR1C1 = "Block Count"
    .Range("A1:D1").Select
    .Selection.Font.Bold = True
    .Columns("A:B").Select
    intRow = 2
    intType(0) = 0
    varDat(0) = "INSERT"
    Set objSelSet = vbdPowerSet("sortblocks")
    objSelSet.Select acSelectionSetAll, filtertype:=intType, _
    filterdata:=varDat
    blnTop = False
    For Each objBlkRef In objSelSet
      .Cells(intRow, intCnt + 1).Value = objBlkRef.Name
      intRow = intRow + 1
    Next objBlkRef
    .ActiveSheet.Range("A1").Sort _
    key1:=.ActiveSheet.Columns("A"), _
    Header:=xlGuess
    .Range("A1").Select
    Set objNext = .ActiveCell.Offset(1, 0)
      Do While objNext <> ""
        .ActiveCell.Offset(1, 0).Select
        intBlkCnt = 1
Check_Value:
      Set objNext = .ActiveCell.Offset(1, 0)
      If .ActiveCell.Value = objNext.Value Then
        intBlkCnt = intBlkCnt + 1
        .ActiveCell.Offset(1, 0).Select
        .Selection.Delete Shift:=xlUp
        .ActiveCell.Offset(-1, 0).Select
        GoTo Check_Value
      Else
        .ActiveCell.Offset(0, 1).Select
        .ActiveCell.Value = intBlkCnt
        .ActiveCell.Offset(0, -1).Select
      End If
    Loop
  End With
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Public Function vbdPowerSet(strName As String) As AcadSelectionSet
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = strName Then
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
  Set vbdPowerSet = objSelSet
End Function
 

Option Explicit

Public Sub ReduceNameLength()
  Dim objBlk As AcadBlock
  Dim objBlks As AcadBlocks
  Dim intCnt As Integer
  Set objBlks = ThisDrawing.Blocks
  For Each objBlk In objBlks
    If Len(objBlk.Name) > 31 Then
      intCnt = intCnt + 1
      objBlk.Name = "Block" & intCnt
    End If
  Next objBlk
End Sub
 

Option Explicit

Public Function BlockScales(objBlk As _
AcadBlockReference) As Variant
  Dim dblXScale As Double
  Dim dblYScale As Double
  Dim dblZScale As Double
  Dim varScales As Variant
  dblXScale = objBlk.XScaleFactor
  dblYScale = objBlk.YScaleFactor
  dblZScale = objBlk.ZScaleFactor
  varScales = Array(sblxscale, dblYScale, dblZScale)
  BlockScales = varScales
End Function
 

Option Explicit

Sub changeBlockSeqEndLayer(strNewLayer As String)
  Dim objBlkRef As AcadBlockReference
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objSeqEnd As AcadEntity
  Dim hexString As String
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Set objSelCol = ThisDrawing.SelectionSets
  For Each objSelSet In objSelCol
    If objSelSet.Name = "seqend" Then
      objSelSet.Delete
      Exit For
    End If
  Next objSelSet
  Set objSelSet = objSelCol.Add("seqend")
  intType(0) = 0
  varData(0) = "INSERT"
  objSelSet.Select 5, filtertype:=intType, _
  filterdata:=varData
  For Each objBlkRef In objSelSet
    If objBlkRef.HasAttributes Then
    hexString = "&H" & objBlkRef.Handle
    Set objSeqEnd = objBlkRef
      Do While objSeqEnd.EntityName <> _
      "AcDbSequenceEnd"
        hexString = hexString + 1
        Set objSeqEnd = _
        ThisDrawing.HandleToObject(Hex(hexString))
      Loop
      objBlkRef.Layer = strNewLayer
      objSeqEnd.Layer = strNewLayer
    End If
  Next
End Sub

Public Sub TEST_changeBlockSeqEndLayer()
  Dim strLayerName As String
  
  ' Замените имя слоя Layer1 на любое другое,
  ' определенное в чертеже.
  strLayerName = "Layer1"
  changeBlockSeqEndLayer strLayerName
End Sub
 

Option Explicit

Public Sub RunReplace()
  Dim objBlkRef As AcadBlockReference
  Dim objSelSet As AcadSelectionSet
  Dim objAllSets As AcadSelectionSets
  Dim objSpace As AcadBlock
  Dim intType(1) As Integer
  Dim varData(1) As Variant
  Dim varPnt As Variant

  '//BUILD SELECTION SET
  Set objAllSets = ThisDrawing.SelectionSets
  For Each objSelSet In objAllSets
    If objSelSet.Name = "replacingblocks" Then
      objSelSet.Delete
      Exit For
    End If
  Next objSelSet
  Set objSelSet = objAllSets.Add("replacingblocks")
  intType(0) = 0
  intType(1) = 2
  varData(0) = "INSERT"
  varData(1) = "myblock"
  objSelSet.Select acSelectionSetAll, _
  filtertype:=intType, filterdata:=varData

  '//REPLACE OLD WITH NEW
  For Each objBlkRef In objSelSet
    varPnt = objBlkRef.InsertionPoint
    'get the correct space
    Set objSpace = ThisDrawing.ObjectIdToObject(objBlkRef.OwnerID)
    objBlkRef.Delete
    objSpace.InsertBlock varPnt, "c:\myblock.dwg", 1#, 1#, 1#, 0
  Next objBlkRef
End Sub
 

Option Explicit

'@~~~~~~~~~~~~~~ VBD_InsertBlock ~~~~~~~~~~~~~~~~~~@
'Insert a block with attributes and allow the user
'To enter the attribute values.
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function VBD_InsertBlock(strBlkName As String, _
Optional varInsert As Variant, Optional dblScale As Double = 1, _
Optional dblRotation As Double = 0) _
As AcadBlockReference
  Dim objTemp As AcadBlockReference
  Dim objBlk As AcadBlock
  Dim colBlks As AcadBlocks
  Dim strPrompt As String
  Dim strReply As String
  Dim varAtts As Variant
  Dim intCnt As Integer
  On Error GoTo Err_Control
  Set colBlks = ThisDrawing.Blocks
  Set objBlk = colBlks.Item(strBlkName)
  If IsMissing(varInsert) Then
    varInsert = ThisDrawing.Utility.GetPoint(Prompt:=vbCrLf & _
    "Select Insertion Point: ")
  End If
  If ThisDrawing.ActiveSpace = acModelSpace Then
    Set objTemp = ThisDrawing.ModelSpace.InsertBlock(varInsert, strBlkName, _
    dblScale, dblScale, dblScale, dblRotation)
  Else
    Set objTemp = ThisDrawing.PaperSpace.InsertBlock(varInsert, strBlkName, _
    dblScale, dblScale, dblScale, dblRotation)
  End If
  If objTemp.HasAttributes Then
    varAtts = objTemp.GetAttributes
    ThisDrawing.Utility.Prompt vbCrLf & "Enter Attribute values" & vbCrLf
    For intCnt = LBound(varAtts) To UBound(varAtts)
      strPrompt = vbCr & "Enter <" & varAtts(intCnt).TextString & "> "
      strReply = ThisDrawing.Utility.GetString(1, strPrompt)
      If strReply <> "" Then
        varAtts(intCnt).TextString = strReply
      End If
    Next
  End If
  Set VBD_InsertBlock = objTemp
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function

Public Sub TEST_VBD_InsertBlock()
Dim strBlkName As String
Dim varInsPnt As Variant
Dim dblScale As Double
Dim dblRotAng As Double
Dim objBlock As AcadBlockReference

  On Error GoTo Err_Handler
  With ThisDrawing.Utility
    varInsPnt = .GetPoint(, vbCrLf & "Укажите точку вставки блока: ")
    dblScale = .GetReal(vbCrLf & "Задайте масштаб вставки блока: ")
    dblRotAng = .GetAngle(, vbCrLf & "Угол поворота блока: ")
  End With
  ' В место заданного здесь имени вставляемого блока нужна подставить
  ' имя любого другого блока определенного в чертеже или задать
  ' имя файла, вставляемого как блок. Но, задавая имя файла
  ' нужно задать его полное имя с путем. Например:
  ' strBlkName = "C:\Program Files\ACAD2000\SUPPORT\sh_spot.dwg"
  strBlkName = "sh_spot"
  Set objBlock = VBD_InsertBlock(strBlkName, varInsPnt, _
  dblScale, dblRotAng)
  Exit Sub
Err_Handler:
  MsgBox Err.Description
  Err.Clear
End Sub
 

Option Explicit

Public Function FillInTheBlnks(sDBPath As String, _
sTableName As String, TitleBlock As AcadBlockReference) As Boolean
  Dim objDB As DAO.Database
  Dim objWorkSpace As DAO.Workspace
  Dim objRecSet As DAO.Recordset
  Dim objField As DAO.Field
  Dim intCnt As Integer
  Dim vArray As Variant
  Dim blnTemp As Boolean
  On Error GoTo Err_Control
  Set objWorkSpace = DBEngine.Workspaces(0)
  Set objDB = objWorkSpace.OpenDatabase(sDBPath)
  Set objRecSet = objDB.OpenRecordset(sTableName)
  If TitleBlock.HasAttributes Then
    vArray = TitleBlock.GetAttributes
    For Each objField In objRecSet.Fields
      For intCnt = LBound(vArray) To UBound(vArray)
        If StrComp(objField.Name, vArray(intCnt).TagString, _
        vbTextCompare) <> 0 Then
          vArray(intCnt).TextString = objField.Value
          Exit For
        End If
      Next intCnt
    Next objField
    blnTemp = True
  Else
    blnTemp = False
  End If
  objRecSet.Close
  objDB.Close
  objWorkSpace.Close
Exit_Here:
  FillInTheBlnks = blnTemp
  Exit Function
Err_Control:
  blnTemp = False
  Err.Clear
  Resume Exit_Here
End Function
 

Option Explicit

Public Sub AttributesToText()
  Dim varPnt As Variant
  Dim varPoint As Variant
  Dim varAtts As Variant
  Dim varHt As Variant
  Dim intCnt As Integer
  Dim objBlk As Object
  Dim strPrompt As String
  
  On Error GoTo Err_Control:

  strPrompt = vbCrLf & "Pick start point for text column: "
  varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt)
  strPrompt = vbCrLf & "Pick block with attributes to convert: "
  ThisDrawing.Utility.GetEntity objBlk, varPoint, strPrompt
  If TypeOf objBlk Is AcadBlockReference Then
    If objBlk.HasAttributes Then
    varAtts = objBlk.GetAttributes
      For intCnt = LBound(varAtts) To UBound(varAtts)
        varHt = varAtts(intCnt).Height
        If ThisDrawing.ActiveSpace = acModelSpace Then
          ThisDrawing.ModelSpace.AddText varAtts(intCnt).TextString, _
          varPnt, varHt
        Else
          ThisDrawing.PaperSpace.AddText varAtts(intCnt).TextString, _
          varPnt, varHt
        End If
        'you will want to set your own offset distance
        ' Вы можете сами задать дисстанцию, с которой будут
        ' расставлены текстовые объекты
        varPnt(1) = varPnt(1) + (CDbl(varHt) * 1.5)
      Next
    End If
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 

Option Explicit

Public Function ExtendedInsert(BlkName As String, _
dblScale As Double, dblRotation As Double) As AcadBlockReference
  Dim objTemp As AcadBlockReference
  Dim varPnt As Variant
  Dim strPrompt As String
  Dim objAtts As Variant
  Dim intCnt As Integer
  
  strPrompt = "Pick Insertion point for " & BlkName & ": "
  If ThisDrawing.ActiveSpace = acModelSpace Then
    varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt)
    Set objTemp = ThisDrawing.ModelSpace.InsertBlock(varPnt, BlkName, _
    dblScale, dblScale, dblScale, dblRotation)
  Else
    varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt)
    Set objTemp = ThisDrawing.ModelSpace.InsertBlock(varPnt, BlkName, _
    dblScale, dblScale, dblScale, dblRotation)
  End If
  If objTemp.HasAttributes Then
      objAtts = objTemp.GetAttributes
      For intCnt = LBound(objAtts) To UBound(objAtts)
        With objAtts(intCnt)
          'Change to match your constant scale
          .ScaleEntity .InsertionPoint, 1 / dblScale
        End With
      Next intCnt
    End If
End Function

Public Sub TEST_ExtendedInsert()
  Dim strBlkName As String
  Dim dblScale As Double
  Dim dblRotAng As Double
  Dim objBlock As AcadBlockReference
  
  dblScale = 2
  dblRotAng = 0
  ' Измените имя блока на определенное в чертеже
  strBlkName = "TEST"
  dblScale = ThisDrawing.Utility.GetReal(vbCrLf & _
  "Задайте масштаб вставки блока: ")
  Set objBlock = ExtendedInsert(strBlkName, dblScale, dblRotAng)
End Sub
 

Option Explicit

Public Sub LevelAttributes()
  Dim objGen As AcadEntity
  Dim objAtts As Variant
  Dim varPnt As Variant
  Dim intCnt As Integer

  ThisDrawing.Utility.GetEntity objGen, varPnt, "Select a block: "
  If TypeOf objGen Is AcadBlockReference Then
    If objGen.HasAttributes Then
      objAtts = objGen.GetAttributes
      For intCnt = LBound(objAtts) To UBound(objAtts)
        With objAtts(intCnt)
          .Rotate objAtts(intCnt).InsertionPoint, -.Rotation
        End With
      Next intCnt
    End If
  End If
End Sub
 

Option Explicit

Public Sub AttributesON()
  Dim objEnt As AcadEntity
  Dim objBlkRef As AcadBlockReference
  Dim objAtt As AcadAttributeReference
  Dim varPnt As Variant
  Dim varAtts As Variant
  Dim strPrmt As String
  Dim intCnt As Integer
  On Error GoTo Err_Control
  strPrmt = "Select Block with invisible attribute(s): "
  ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmt
  If TypeOf objEnt Is AcadBlockReference Then
    Set objBlkRef = objEnt
    If objBlkRef.HasAttributes Then
      varAtts = objBlkRef.GetAttributes
      For intCnt = LBound(varAtts) To UBound(varAtts)
        Set objAtt = varAtts(intCnt)
        If objAtt.Invisible = True Then
          objAtt.Invisible = False
        End If
      Next intCnt
    Else
      MsgBox "No attributes found."
    End If
  Else
    MsgBox "Selected entity is not a block reference."
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 

Option Explicit

Public Sub ColorAttributes(sBlockName As String, _
iColor As Integer)
  Dim objBlks As AcadBlocks
  Dim objBlk As AcadBlock
  Dim objEnt As AcadEntity
  Set objBlks = ThisDrawing.Blocks
  Set objBlk = objBlks(sBlockName)
  If Not objBlk.IsLayout And Not _
  objBlk.IsXRef Then
    For Each objEnt In objBlk
      If TypeOf objEnt Is AcadAttribute Then
        objEnt.Color = iColor
      End If
    Next objEnt
  End If
  Set objBlks = Nothing
End Sub

Public Sub TEST_ColorAttributes()
  Dim strBlockName As String
  Dim intColor As Integer
  
  ' Замените имя блока "TestBlkName" на любое, определенное
  ' в чертеже имя блока с аттрибутами
  strBlockName = "TestBlkName"
  ' Изменяем цвет аттрибутов на желтый
  intColor = 2
  ColorAttributes strBlockName, intColor
End Sub
 

Option Explicit

Public Function GetAttributeReferences(sBlockName As String) As Variant
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objBlkRef As AcadBlockReference
  Dim objAttRef As AcadAttributeReference
  Dim objCat As AcadAttribute
  Dim intCnt As Integer
  Dim varAtts As Variant
  Dim varCatts
  Dim varData(1) As Variant
  Dim intType(1) As Integer
  Dim intKeepCnt As Integer
  Dim objAtts() As Object
  Dim varRet As Variant
  On Error GoTo Err_Control
  'Check to see if the name we are going to use for the
  'Selection set has been used before (we ran this process)
  'If it is, remove it.
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = "vbdblkrefset" Then
        objSelSet.Delete
        Exit For
      End If
    Next
  'It is now safe to Set the selection set into the collection
  Set objSelSet = objSelCol.Add("vbdblkrefset")
  'Build the filter
  intType(0) = 0
  varData(0) = "INSERT"
  intType(1) = 2
  varData(1) = sBlockName
  'Get the blocks
  objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, _
  filterdata:=varData
  'Do the search
  For Each objBlkRef In objSelSet
    If objBlkRef.HasAttributes Then
      varAtts = objBlkRef.GetAttributes
      For intCnt = LBound(varAtts) To UBound(varAtts)
        Set objAttRef = varAtts(intCnt)
        ReDim Preserve objAtts(intKeepCnt)
        Set objAtts(intKeepCnt) = objAttRef
        intKeepCnt = intKeepCnt + 1
      Next intCnt
      'Get Any constant Attributes
      varCatts = objBlkRef.GetConstantAttributes
      'Test varCatts, is it an array?
      If VarType(varCatts) And vbArray = vbArray Then
        For intCnt = LBound(varCatts) To UBound(varCatts)
          Set objCat = varCatts(intCnt)
          ReDim Preserve objAtts(intKeepCnt)
          Set objAtts(intKeepCnt) = objCat
          intKeepCnt = intKeepCnt + 1
        Next intCnt
      End If
    End If
  Next objBlkRef
  varRet = objAtts
  GetAttributeReferences = varRet
Exit_Here:
  Exit Function
Err_Control:
  Select Case Err.Number
  'Add your Case selections here
    Case Else
    MsgBox Err.Description
    Resume Exit_Here
  End Select
End Function

Public Sub ColorMeBlue()
  Dim varAttRefs As Variant
  Dim intCnt As Integer
  On Error GoTo Err_Control
  ' Замените имя блока "TestBlkName" на любое, определенное
  ' в чертеже имя блока с аттрибутами
  varAttRefs = GetAttributeReferences("TestBlkName")
  If VarType(varAttRefs) And vbArray = vbArray Then
    For intCnt = LBound(varAttRefs) To UBound(varAttRefs)
      varAttRefs(intCnt).Color = 5
    Next intCnt
  End If
  If MsgBox("About to regen, Ok to proceed?", _
  vbOKCancel) = vbOK Then
    ThisDrawing.Regen acAllViewports
  End If
Exit_Here:
  Exit Sub
Err_Control:
  Select Case Err.Number
  'Add your Case selections here
    Case Else
    MsgBox Err.Description
    Resume Exit_Here
  End Select
End Sub
 

Option Explicit

Private Sub AcadDocument_BeginClose()
  Dim blnCloseAllowed As Boolean
  blnCloseAllowed = IsValidName
  Do Until blnCloseAllowed
    blnCloseAllowed = IsValidName(InputBox("Enter Your Code"))
  Loop
End Sub
 
Public Function IsValidName(Optional strName As Variant) As Boolean
  Dim objBlkRef As AcadBlockReference
  Dim objSelSet As AcadSelectionSet
  Dim objAllSets As AcadSelectionSets
  Dim intType(1) As Integer
  Dim varData(1) As Variant
  Dim strUser As String
  Dim strCurVal As String
  Dim varAtts As Variant
  Dim intCnt As Integer

  strUser = "Code"

  Set objAllSets = ThisDrawing.SelectionSets
  For Each objSelSet In objAllSets
    If objSelSet.Name = "validate" Then
      objSelSet.Delete
      Exit For
    End If
  Next objSelSet
  Set objSelSet = objAllSets.Add("validate")
  intType(0) = 0
  intType(1) = 2
  varData(0) = "INSERT"
  varData(1) = "TITLEBLOCK"
  'This should return only one instance!
  objSelSet.Select acSelectionSetAll, _
  filtertype:=intType, filterdata:=varData
  Set objBlkRef = objSelSet.Item(0)
  varAtts = objBlkRef.GetAttributes
  For intCnt = LBound(varAtts) To UBound(varAtts)
    If varAtts(intCnt).TagString = "DRAFTSMAN" Then
      If IsMissing(strName) Then
        strCurVal = varAtts(intCnt).TextString
        0080">If strCurVal = strUser Then
          IsValidName = True
        Exit For
        End If
      Else
        If strName = strUser Then
          varAtts(intCnt).TextString = strName
          ThisDrawing.Save
          IsValidName = True
          Exit For
        End If
      End If
    End If
  Next intCnt
End Function
 

Option Explicit

'Win32API Constants for CheckKey
Public Const VK_ESCAPE = &H1B
Public Const VK_RETURN = &HD
Public Const VK_RBUTTON = &H2
Public Const VK_LBUTTON = &H1

'Win32API Constants for ClearAllKeyPress
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const PM_REMOVE = &H1

'Win32API Declare for CheckKey
Public Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As Long) As Integer

'Win32API Declare for ClearAllKeyPress
Public Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" _
(lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, _
ByValwMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long

'This is for AutoCAD R14 users that do not have the Hwnd property
'In clear all key press, change:
'lngHwnd = ThisDrawing.hwnd
'To
'lngHwnd = FindWindow(vbNullString, Application.Caption)
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'Win32API Types
Public Type POINTAPI
       x As Long
       y As Long
End Type

Public Type MSG
   hwnd As Long
   message As Long
   wParam As Long
   lParam As Long
   Time As Long
   pt As POINTAPI
End Type

'@~~~~~~~~~~ TransferTextValue ~~~~~~~~~~~~~~~@
' Pick any attribute, text, or Mtext to set
' The transfer value. Next select the target
' Attribute, MText, or Text object. The transfer
' Value is applied to the targets Text string
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Sub TransferTextValue()
  Dim objSource As AcadEntity
  Dim objTarget As AcadEntity
  Dim varPnt As Variant
  Dim varPntN As Variant
  Dim varSubIDs As Variant
  Dim varsubID2 As Variant
  Dim varMatrix As Variant
  Dim strPrompt As String
  Dim varValue As Variant

Pick_One:
  On Error GoTo Err_Control
  ClearAllKeyPress
  strPrompt = "Pick the source object (MText, Text, or Attribute): "
  ThisDrawing.Utility.GetSubEntity objSource, varPnt, _
  varMatrix, varSubIDs, strPrompt
  varValue = objSource.TextString

Pick_Two:
  ClearAllKeyPress
  strPrompt = "Pick the target object (MText, Text, or Attribute): "
  ThisDrawing.Utility.GetSubEntity objTarget, varPntN, _
  varMatrix, varsubID2, strPrompt
  objTarget.TextString = varValue

Exit_Here:
  Exit Sub

Err_Control:
  If Err.Number = 438 Then
    If varValue = "" Then
      Resume Pick_One
    Else
      Resume Pick_Two
    End If
  ElseIf Err.Number = -2147352567 Then
  'Did the user miss or are they trying to exit?
    If checkkey(VK_LBUTTON) Then
    'left click? oops they missed
      If objSource Is Nothing Then
      ' But what pick ?
        Resume Pick_One
      Else
        Resume Pick_Two
      End If
    Else
      Resume Exit_Here
    End If
  Else
    ThisDrawing.Utility.Prompt Err.Description
    Resume Exit_Here
  End If
End Sub

'///////////// Function and Sample Call //////////
'@~~~~~~~~~~~~~ Change Case ~~~~~~~~~~~~~~~~~~~@
' Convert the Case of any textual entity. the
' Argument "intCase" can be:
' 1 = Uppercase
' 2 = Lowercase
' 3 = Propercase
' You could also include the other constants
' For general string conversion(vbWide, vbNarrow,
' Etc..)
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ChangeCase(intCase As Integer) As Boolean
  Dim objEnt As AcadEntity
  Dim varPnt As Variant
  Dim varSubIDs As Variant
  Dim varMatrix As Variant
  Dim strVal As String
  Dim strPrompt As String
  
  On Error GoTo Err_Control
  If intCase > 0 And intCase < 4 Then
    strPrompt = "Pick the textual object for case change: "
    ThisDrawing.Utility.GetSubEntity objEnt, varPnt, _
    varMatrix, varSubIDs, strPrompt
    strVal = objEnt.TextString
    objEnt.TextString = StrConv(strVal, intCase)
    ChangeCase = True
  End If

Exit_Here:
  Exit Function
Err_Control:
  If Err.Number = 438 Then
    ThisDrawing.Utility.Prompt "Selected Entity does not have a text value."
  ElseIf Err.Number = -2147352567 Then
    ThisDrawing.Utility.Prompt "No entity selected."
  Else
    ThisDrawing.Utility.Prompt Err.Description
  End If
  Resume Exit_Here
End Function

Public Sub TEST_ChangeCase()
  Call ChangeCase(1)
  Call ChangeCase(2)
  Call ChangeCase(3)
End Sub

'//////////// End combined code ////////////////
'@~~~~~~~~~~~~~~~~~~~ VBDEdit ~~~~~~~~~~~~~~~~~@
' Like DDEDIT, except it works on attributes and
' Text or MText.
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Sub VBDEdit()
  Dim objEnt As AcadEntity
  Dim varPnt As Variant
  Dim varSubIDs As Variant
  Dim varMatrix As Variant
  Dim strVal As String
  Dim strNew As String
  Dim strPrompt As String

Do_Retry:
  On Error GoTo Err_Control
  Do
    ClearAllKeyPress
    strPrompt = "Pick the textual object for string modification: "
    ThisDrawing.Utility.GetSubEntity objEnt, varPnt, _
    varMatrix, varSubIDs, strPrompt
    strVal = objEnt.TextString
    strNew = InputBox(Prompt:="New Value", Default:=strVal)
    If Len(strNew) > 0 Then
      objEnt.TextString = strNew
    End If
  Loop

Exit_Here:
  Exit Sub

Err_Control:
  If Err.Number = 438 Then
    Resume Do_Retry
    'This is the error generated by Nothing picked:
  ElseIf Err.Number = -2147352567 Then
    'We are in a loop, so we check to see if the user wants out
    'or if they missed their pick.
    If checkkey(VK_LBUTTON) Then
    'left click? oops they missed
      Resume Do_Retry
    Else
      'Anything else means they want out!
      Resume Exit_Here
    End If
  Else
    ThisDrawing.Utility.Prompt Err.Description
    Resume Exit_Here
  End If
End Sub

Public Sub MoveAttribute()
  Dim objEnt As AcadEntity
  Dim varPnt As Variant
  Dim varBase As Variant
  Dim varDisp As Variant
  Dim varSubIDs As Variant
  Dim varMatrix As Variant
  Dim strVal As String
  Dim strKeys As String
  Dim strPrompt As String
  
  On Error GoTo Err_Control
  strKeys = "Insert"
  strPrompt = "Pick Attribute to move: "

Do_Retry:
    ThisDrawing.Utility.GetSubEntity objEnt, varPnt, _
    varMatrix, varSubIDs, strPrompt
    'Force an attribute selection by keeping the loop
    'Until an attribute reference is returned.
    'Of course an error will move to the error handler
    'which is good, because we can use to detect an
    'escape.
    If TypeOf objEnt Is AcadAttributeReference Then
      strPrompt = "Select base point for move [Insert]: "
      ThisDrawing.Utility.InitializeUserInput 32, strKeys
      On Error Resume Next
      varBase = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt)
      If Err Then
        If Err.Description = "User input is a keyword" Then
          varBase = objEnt.InsertionPoint
          Err.Clear
        Else
          GoTo Err_Control
        End If
      End If
      On Error GoTo Err_Control
      strPrompt = "Select displacement point: "
      varDisp = ThisDrawing.Utility.GetPoint(varBase, strPrompt)
      objEnt.Move varBase, varDisp
    Else
      GoTo Do_Retry
    End If
Exit_Here:
  Exit Sub
Err_Control:
  If Err.Number = -2147352567 Then
    'We are in a loop, so we check to see if the user wants out
    'or if they missed their pick.
    If checkkey(VK_ESCAPE) Then
    'They really want out
      Resume Exit_Here
    ElseIf checkkey(VK_LBUTTON) Then
    'left click? oops they missed
      Resume Do_Retry
    ElseIf checkkey(VK_RBUTTON) Then
    'another exit key (right click)
      Resume Exit_Here
    End If
  Else
    ThisDrawing.Utility.Prompt "Function canceled"
  End If
  Resume Exit_Here
End Sub

'@~~~~~~~~~~~~~~~ ApplyDate ~~~~~~~~~~~~~~~@
' Apply the current date to any attribute
' or (M)Text
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Sub ApplyDate()
  Dim objEnt As AcadEntity
  Dim varPnt As Variant
  Dim varSubIDs As Variant
  Dim varMatrix As Variant
  Dim strVal As String
  Dim strPrompt As String
  Dim varDate As Variant

Do_Retry:
  On Error GoTo Err_Control
    strPrompt = "Pick annotation to modify: "
    ThisDrawing.Utility.GetSubEntity objEnt, varPnt, _
    varMatrix, varSubIDs, strPrompt
    'Use the format function to change the format of the date
    objEnt.TextString = Date 'this returns mm/dd/yyyy
Exit_Here:
  Exit Sub
Err_Control:
  If Err.Number = 438 Then
    Resume Do_Retry
  ElseIf Err.Number = -2147352567 Then
  'We are in a loop, so we check to see if the user wants out
  'or if they missed their pick.
    If checkkey(VK_ESCAPE) Then
    'They really want out
      Resume Exit_Here
    ElseIf checkkey(VK_LBUTTON) Then
    'left click? oops they missed
      Resume Do_Retry
    ElseIf checkkey(VK_RBUTTON) Then
    'another exit key (right click)
      Resume Exit_Here
    End If
  Else
    ThisDrawing.Utility.Prompt Err.Description
  End If
  Resume Exit_Here
End Sub

']---[ ]---[ ]---[ ]---[ ]---[ ]---[ ]---[
' Utility functions for the module
']---[ ]---[ ]---[ ]---[ ]---[ ]---[ ]---[
'@~~~~~~~~~~~~~~ CheckKey ~~~~~~~~~~~~~~~~~@
' Check to see if a particular key has been
' pressed. lngKey is provided by the Const
' in the general declararions.
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Function checkkey(lngKey As Long) As Boolean
  If GetAsyncKeyState(lngKey) Then
    checkkey = True
  Else
    checkkey = False
  End If
End Function

'@~~~~~~~~~~~~~~~ ClearAllKeyPress ~~~~~~~~~~~~~~~~~~~~~~~~@
' Used to clear the mouse clicks (can be used for key press
' You will just need to use different constants) so CheckKey
' Can get a clear read.
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Sub ClearAllKeyPress()
  Dim lngHwnd As Long
  Dim ThisMSG As MSG
  
  lngHwnd = ThisDrawing.hwnd
  Do While PeekMessage(ThisMSG, lngHwnd, WM_LBUTTONDOWN, _
  WM_LBUTTONUP, PM_REMOVE) <> 0
  Loop
End Sub