Команды AutoCAD

Пример функции, выполняющей над заданным объектом любую команду AutoCAD

                 Public Function GetJig_gy(strVerb As String) As AcadEntity
     ' The following is a basic HACK (as in hair ball)
     ' It can be improved on in many ways, but not by me!
     Dim objEnt As AcadEntity
     Dim varPnt As Variant
     Dim strPrmt As String
     Dim strCommand As String

     ' Запрос у пользователя примитива
     strPrmt = vbCr & "select entity to " & strVerb & ":"
     ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmt
     
     ' Выполняем команду strCommand  над примитивом objEnt
     strCommand = strVerb & vbCr & "L"
     ThisDrawing.SendCommand strCommand & vbCr & vbCr
     Set GetJig_gy = objEnt
     ' Add error control!
     ' And watch out if you pass the Erase command or Explode!
     ' The return value will get you!!
   End Function
   
   
   Sub GetJig_gy_Test()
   ' Тест функции GetJig_gy
     Dim AE As AcadEntity
     Set AE = GetJig_gy("_copy")
   End Sub

Определение и отмена текущей команды.

Поместите пример в модуль ThisDrawing
Теперь, если пользователь использует команду ERASE и глобальная переменная blnNoErase=False, то команда отменяется. Если же blnNoErase=True, то команда выполняется.

Option Explicit '//Limitations: '//This will not stop the command if the object is picked first! Dim blnNoErase As Boolean Public Sub ToggleErase() blnNoErase = Not blnNoErase End Sub Private Sub AcadDocument_BeginCommand(ByVal CommandName As String) If CommandName = "ERASE" Then If Not blnNoErase Then SendKeys "{Esc}" End If End If End Sub

Запуск процедуры VBA из командной строки

Создвайте файл AutoLISP, в который добавте следующее:

;; Test VBA COMMAND (defun c:vbatest (/) (princ) )

Добавьте в стандартный модуль проекта следующий код:

Public Sub VBATest() MsgBox "What do you know, it works" End Sub

Затем добавьте в модуль ThisDrawing следующий код:

Private Sub AcadDocument_BeginLisp(ByVal FirstLine As String) If FirstLine = "(C:VBATEST)" Then Call VBATest End If End Sub

Команда Array (Массив копий)

Использование команды ArrayRectangular.

Создание прямоугольного массива копий группы объектов с заданным именем, количеством колонок и строк, отстоящих друг от друга на заданное расстояние.
Создайте группу объектов с именем "TestGroupName" и запустите процедуру TEST_ArrayGroup

Public Sub ArrayGroup(strName As String, lngColumns As Long, _
lngRows As Long, dblDist As Double)
  Dim objGroup As AcadGroup
  Dim objGen As AcadEntity
  Set objGroup = ThisDrawing.Groups.Item(strName)
  For Each objGen In objGroup
    objGen.ArrayRectangular lngRows, lngColumns, 1, dblDist, _
    dblDist, dblDist
  Next objGen
End Sub

Sub TEST_ArrayGroup()
    ArrayGroup "TestGroupName", 5, 3, 50
End Sub

Команда Break (Разрыв объекта)

Набор функций для разрыва отрезка по двум заданным точкам

Кроме основной функции используется вспомогательная функция NearestTo, которая возвращает точку, ближайшую к заданной и лежащую на заданном отрезке

Public Sub TEST_ Break()
  Call Break
End Sub

Public Function Break() As Variant
  Dim objLine As AcadLine
  Dim objOne As AcadLine
  Dim objTwo As AcadLine
  Dim objSpace As AcadBlock
  Dim dblAng As Double
  Dim varPnt As Variant
  Dim varNear As Variant
  Dim varFirst As Variant
  Dim varSecond As Variant
  Dim strPrmt As String
  On Error GoTo Err_Control
  If ThisDrawing.ActiveSpace = acModelSpace Then
    Set objSpace = ThisDrawing.ModelSpace
  Else
    Set objSpace = ThisDrawing.PaperSpace
  End If
  strPrmt = vbCr & "Select Line to break: "
  ThisDrawing.Utility.GetEntity objLine, varPnt, strPrmt
  strPrmt = vbCr & "Select First Point: "
  varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrmt)
  varFirst = NearestTo(objLine, varPnt)

  strPrmt = vbCr & "Select Second Point: "
  varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrmt)
  varSecond = NearestTo(objLine, varPnt)
  dblAng = ThisDrawing.Utility.AngleFromXAxis(varFirst, varSecond)

  If dblAng >= 3.14159265358979 Then
    If objLine.Angle <= 3.14159265358979 Then
      Set objOne = objSpace.AddLine(objLine.EndPoint, varFirst)
      Set objTwo = objSpace.AddLine(varSecond, objLine.StartPoint)

    Else
      Set objOne = objSpace.AddLine(objLine.StartPoint, varFirst)
      Set objTwo = objSpace.AddLine(varSecond, objLine.EndPoint)
    End If
  Else
    If objLine.Angle >= 3.14159265358979 Then
      Set objOne = objSpace.AddLine(objLine.EndPoint, varFirst)
      Set objTwo = objSpace.AddLine(varSecond, objLine.StartPoint)
    Else

      Set objOne = objSpace.AddLine(objLine.StartPoint, varFirst)
      Set objTwo = objSpace.AddLine(varSecond, objLine.EndPoint)

    End If
  End If
  objLine.Delete
  Break = Array(objOne, objTwo)
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function

Public Function NearestTo(objLine As AcadLine, _
varPoint As Variant) As Variant
  Dim objUtil As Object
  Dim varTemp As Variant
  Dim dblSlope As Double
  Dim dblInvSlope As Double
  Dim dblTemp(0 To 2) As Double
  Dim dblAng As Double
  Dim vStart As Variant
  Dim vEnd As Variant
  Dim x1 As Double
  Dim y1 As Double
  Dim x2 As Double
  Dim y2 As Double
  Dim x3 As Double
  Dim y3 As Double
  Dim Y1Intercept As Double
  Dim Y2Intercept As Double
  On Error GoTo Err_Control
  vStart = objLine.StartPoint
  vEnd = objLine.EndPoint
  x1 = vStart(0)
  y1 = vStart(1)
  x2 = vEnd(0)
  y2 = vEnd(1)
  x3 = varPoint(0)
  y3 = varPoint(1)
  dblSlope = (y2 - y1) / (x2 - x1)
  If dblSlope <> 0 Then
    dblInvSlope = -1 / dblSlope
  Else
    dblInvSlope = 0
  End If
  Y1Intercept = y1 - (dblSlope * x1)
  Y2Intercept = y3 - (dblInvSlope * x3)
  If dblSlope <> 0 Then
    dblTemp(0) = (Y1Intercept - Y2Intercept) / _
    (dblInvSlope - dblSlope)
  Else
    dblTemp(0) = x3
  End If
  dblTemp(1) = (dblSlope * dblTemp(0)) + Y1Intercept
  Set objUtil = ThisDrawing.Utility
  objUtil.CreateTypedArray varTemp, vbDouble, _
  dblTemp(0), dblTemp(1), dblTemp(2)
  NearestTo = varTemp
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here

End Function

Команды Copy (Копирование), Move (Перемещение) и Rotate (Поворот)

Пример перемещения текстовых объектов

Эта процедура предлагает выбрать несколько примитивов чертежа рамкой. Затем все текстовые объекты полученного набора подвергаются следующему:
1. Определяется содержимое текстового объекта.
2. Если содержимое текстового объекта является числом, то Z составляющая точки вставки текста устанавливается раной этому числу.

Public Sub MoveTextObjects()
  Dim Point1(0 To 2) As Double
  Dim Point2(0 To 2) As Double
  Dim varPnt As Variant
  Dim objSelectionSet As AcadSelectionSet
  ' Unless we filter the selection set, we need the widest base
  ' of selectable entites so..
  Dim textObj As AcadEntity '<---From AcadText
  Dim ZValue As Double
  ' If you feel you MUST use this method of error control,
  ' Reset it as soon as you can by providing an Error handler
  On Error Resume Next
  ThisDrawing.SelectionSets("TempSSet").Delete
  Set objSelectionSet = ThisDrawing.SelectionSets.Add("TempSSet")
  If Err Then
    Err.Clear '<--Keep a clean house
  End If
  On Error GoTo Err_Control
  objSelectionSet.SelectOnScreen
  For Each textObj In objSelectionSet
    ' We could filter the selection set, or we can just test
    ' items here...
    If TypeOf textObj Is AcadText Then
    ' Whoa, need to make sure the string has a numeric value..
      If IsNumeric(textObj.textString) Then
        ' You don't have to force the conversion, but..
        ZValue = CDbl(textObj.textString)
        varPnt = textObj.InsertionPoint
        varPnt(2) = ZValue
        textObj.InsertionPoint = varPnt
        textObj.Update
      End If
    End If
  Next
  objSelectionSet.Delete
Exit_Here:
  Exit Sub
Err_Control:
  ' Absolute minimum error handler
  Debug.Print Err.Description & vbCr & Err.Number
  Resume Exit_Here
End Sub
 
' Is that what you had in mind?

Коприрование и поворот выбранных объектов

Public Sub CopyRotate()
  Dim objEnt As AcadEntity
  Dim objCopy As AcadEntity
  Dim objUtil As AcadUtility
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim dblRot As Double
  Dim varPnt As Variant
  Dim varBase As Variant

  Dim varCancel As Variant
  Dim strPrmt As String
  Dim strKeys As String
  
  ' Запрос у пользователя нескольких объектов
  On Error GoTo Err_Control
  Set objUtil = ThisDrawing.Utility
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = "copyrotate" Then
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = objSelCol.Add("copyrotate")
  objSelSet.SelectOnScreen
  ' Окончание запроса нескольких объектов

  strPrmt = vbCr & "Base point: "
  varBase = objUtil.GetPoint(Prompt:=strPrmt)
  strPrmt = vbCr & "Displacement point: "
  objUtil.InitializeUserInput 33
  varPnt = objUtil.GetPoint(varBase, strPrmt)
  strPrmt = vbCr & "Rotation: "
  objUtil.InitializeUserInput 33
  dblRot = objUtil.GetAngle(varPnt, strPrmt)
  For Each objEnt In objSelSet
    Set objCopy = objEnt.Copy
    objCopy.Move varBase, varPnt
    objCopy.Rotate varPnt, dblRot
  Next objEnt
  objSelSet.Delete
  Set objSelSet = Nothing
  Set objUtil = Nothing
  Set objCopy = Nothing
Exit_Here:
  Exit Sub
Err_Control:
  varCancel = ThisDrawing.GetVariable("LASTPROMPT")
  If InStr(1, varCancel, "*Cancel*") <> 0 Then
    Err.Clear
    Resume Exit_Here
  Else
    MsgBox Err.Description
    Resume Exit_Here
  End If
End Sub

Команда Offset (Эквидистанта)

Эквидистантная копия объекта на заданный слой
с примером диалогового окна для выбора слоев

Поместите следующий код в стандартный модуль:

Option Explicit

Public strLayer As String

Public Sub OffsetToLayer()
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objUtil As AcadUtility
  Dim objEnt As AcadEntity
  Dim varObjs As Variant
  Dim blnFound As Boolean
  Dim strKeys As String
  Dim strOffset As String
  Dim strPrmpt As String
  Dim strReply As String
  Dim dblDist As Double
  Dim intCnt As Integer
  Dim intErr As Integer
  Dim intErrCnt As Integer
  On Error GoTo Err_Control
  strKeys = "Select List Name"
  strOffset = "+ -"
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = "rotate" Then
        objSelSet.Delete
        Exit For
      End If
    Next
 
  ' Запрос у пользователя с использованием ключевых слов
  Set objSelSet = ThisDrawing.SelectionSets.Add("rotate")
  Set objUtil = ThisDrawing.Utility
  strPrmpt = vbCrLf & _
  "Layer to offset to [Select by objsect/List layers/<Name>]: "
  Do Until blnFound
    objUtil.InitializeUserInput 0, strKeys
    strReply = objUtil.GetKeyword(strPrmpt)
    If strReply = "List" Then
      Call DisplayLayers
    ElseIf strReply = "Select" Then
      strLayer = SelectByEnt
    ElseIf strReply = "Name" Or strReply = "" Then
      strLayer = objUtil.GetString(False, vbCrLf & "Layer Name: ")
    End If
    strPrmpt = vbCrLf & "Layer " & strLayer & _
    " not found. Layer name [Select by objsect/List layers/<Name>]: "
    objUtil.InitializeUserInput 0, strKeys
    blnFound = ValidateLayer(strLayer)
  Loop
  strPrmpt = vbCrLf & "Distance for offset: "
  dblDist = objUtil.GetDistance(Prompt:=strPrmpt)
  objSelSet.SelectOnScreen
  strPrmpt = vbCrLf & "Offset to Greater or Lesser X,Y [+/-] <+>: "
  For Each objEnt In objSelSet
    objEnt.Highlight True
    objEnt.Update
    objUtil.InitializeUserInput 0, strOffset
    strReply = objUtil.GetKeyword(strPrmpt)
    If strReply = "+" Or strReply = "" Then
      varObjs = objEnt.Offset(dblDist)
    ElseIf strReply = "-" Then
      varObjs = objEnt.Offset(-dblDist)
    End If
    objEnt.Highlight False
    If IsArray(varObjs) Then
      For intCnt = LBound(varObjs) To UBound(varObjs)
        varObjs(intCnt).Layer = strLayer
      Next intCnt
    End If
  Next objEnt
  objSelSet.Delete
Exit_Here:
  If intErrCnt > 0 Then
    MsgBox intErrCnt & " Entities did not support VBA Offset"
  End If
  Exit Sub
Err_Control:
  If Err.Description = _
  "Object doesn't support this property or method" Then
    Err.Clear
    intErrCnt = intErrCnt + 1
    Resume Next
  ElseIf InStr(1, Err.Description, "failed", vbTextCompare) > 0 Then
    intErr = CInt(ThisDrawing.GetVariable("ERRNO"))
    If intErr = 52 Then
      Err.Clear
      Resume Exit_Here
    ElseIf intErr = 7 Then
      Err.Clear
      Resume
    End If
  Else
    MsgBox Err.Description
    Debug.Print Err.Description
    Resume Exit_Here
  End If
End Sub

' Проверка наличия в чертеже слоя с заданным именем
Private Function ValidateLayer(strName As String) As Boolean
  Dim objLayer As AcadLayer
  Dim objLayers As AcadLayers
  Set objLayers = ThisDrawing.Layers
  For Each objLayer In objLayers
    If objLayer.Name = strName Then
      ValidateLayer = True
      Exit For
    End If
  Next objLayer
End Function
 
Private Sub DisplayLayers()
  On Error GoTo Err_Control
  frmLayers.Show
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Err.Clear
End Sub
 
' Определение имени слоя по выбранному объекту
Private Function SelectByEnt() As String
  On Error GoTo Err_Control
  Dim objEnt As AcadEntity
  Dim varPnt As Variant
  Dim strPrmpt As String
  Dim intErr As Integer
  strPrmpt = vbCrLf & "Select entity on desired layer: "
  ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmpt
  SelectByEnt = objEnt.Layer
Exit_Here:
  Exit Function
Err_Control:
  If InStr(1, Err.Description, "failed", vbTextCompare) > 0 Then
    intErr = CInt(ThisDrawing.GetVariable("ERRNO"))
    If intErr = 52 Then
      Err.Clear
      Resume Exit_Here
    ElseIf intErr = 7 Then
      Err.Clear
      Resume
    End If
  Else
    MsgBox Err.Description
    Debug.Print Err.Description
    Resume Exit_Here
  End If
End Function

Создайте диалоговое окно как на рисунке

И поместите в модуль форму следующий код:

Option Explicit

Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long

Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTBOTTOMRIGHT = 17
Dim layerInfo() As Variant

Private Sub UserForm_Initialize()
  Dim objLayer As AcadLayer
  Dim intCnt As Integer
  ListBox1.ColumnHeads = True
  ListBox1.ColumnCount = 4
  
  ' Создание массива с данными о слоях чертежа
  ReDim layerInfo(ThisDrawing.Layers.Count - 1, 3)
  For Each objLayer In ThisDrawing.Layers
    layerInfo(intCnt, 0) = objLayer.Name
    layerInfo(intCnt, 1) = objLayer.Color
    If objLayer.Freeze = True Then
      layerInfo(intCnt, 2) = "Fozen"
    Else
      layerInfo(intCnt, 2) = "Thawed"
    End If
    If objLayer.LayerOn Then
      layerInfo(intCnt, 3) = "On"
    Else
      layerInfo(intCnt, 3) = "off"
    End If
    intCnt = intCnt + 1
  Next objLayer
  ListBox1.List = layerInfo
  CommandButton1.Caption = "OK"
  CommandButton2.Caption = "Cancel"
  CommandButton1.Enabled = False
  Me.PictureAlignment = fmPictureAlignmentBottomRight
  ' Replace the path with your own if you would like
  ' The form to have a "Grip"
  ' Me.Picture = LoadPicture("C:\mypath\frmdrag.bmp")
  Me.Caption = "Layer Select & Info"
End Sub

Private Sub ListBox1_Click()
  CommandButton1.Enabled = True
End Sub

Private Sub CommandButton1_Click()
  strLayer = ListBox1.List(ListBox1.ListIndex, 0)
  Unload Me
End Sub

Private Sub CommandButton2_Click()
  Unload Me
End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim lngHwnd As Long
  If X >= Me.Width - 10 Then
    If Y >= Me.Height - 30 Then
      lngHwnd = FindWindow(vbNullString, Me.Caption)
      ReleaseCapture
      SendMessage lngHwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, ByVal 0&
    End If
  End If
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X >= Me.Width - 10 Then
    If Y >= Me.Height - 30 Then
       Me.MousePointer = fmMousePointerSizeNWSE
    End If
  Else
    Me.MousePointer = fmMousePointerDefault
  End If
End Sub

Private Sub UserForm_Resize()
  ListBox1.Width = Me.Width - 20
  ListBox1.Height = Me.Height - 70
  CommandButton1.top = Me.Height - 50
  CommandButton2.top = Me.Height - 50
End Sub

Команда Purge (Очистка базы данных чертежа)

Удаление из базы данных чертежа неиспользуемых блоков

'Begin PurgeBlocks
Public Sub PurgeBlocks()
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objBlkCol As AcadBlocks
  Dim objBlk As AcadBlock
  Dim objGen As AcadEntity
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Dim strKeyWord As String
  Dim blnVerify As Boolean
  Dim strReply As String
  On Error GoTo OH_NO
  strKeyWord = "Yes No"
  ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
  strReply = ThisDrawing.Utility.GetKeyword(vbCrLf _
  & "Verify each name to be purged? [Yes/No] <Y>: ")
  If strReply = "Yes" Then
   blnVerify = True
  ElseIf strReply = "" Then
    blnVerify = True
  Else
    blnVerify = False
  End If
  Set objSelCol = ThisDrawing.SelectionSets
  Set objBlkCol = ThisDrawing.Blocks
  For Each objSelSet In objSelCol
    If objSelSet.Name = "purgeblocks" Then
      ThisDrawing.SelectionSets.Item("purgeblocks").Delete
      Exit For
    End If
  Next
  For Each objBlk In objBlkCol
    If objBlk.IsLayout = False Then
      Set objSelSet = ThisDrawing.SelectionSets.Add("purgeblocks")
      intType(0) = 2
      varData(0) = objBlk.Name
      objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, _
      filterdata:=varData
      If objSelSet.Count = 0 Then
        If blnVerify Then
          ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
          strReply = ThisDrawing.Utility.GetKeyword(vbCrLf & "Purge " _
          & objBlk.Name & " [Yes/No] <Y>: ")
          If strReply = "Yes" Then
            For Each objGen In objBlk
              objGen.Delete
            Next
            objBlk.Delete
          ElseIf strReply = "" Then
            For Each objGen In objBlk
              objGen.Delete
            Next
            objBlk.Delete
          End If
        Else
          For Each objGen In objBlk
            objGen.Delete
          Next
          objBlk.Delete
        End If
      End If
      ThisDrawing.SelectionSets.Item("purgeblocks").Delete
    End If
  Next
Exit_Here:
  Exit Sub
OH_NO:
  ThisDrawing.Utility.Prompt vbCrLf & Err.Description
  Resume Exit_Here
End Sub
'End PurgeBlocks

Удаление из базы данных чертежа неиспользуемых типов линий.

'Begin PurgeLTs
Public Sub PurgeLTs()
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objLTCol As AcadLineTypes
  Dim objLT As AcadLineType
  Dim objLayer As AcadLayer
  Dim objLayers As AcadLayers
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Dim strKeyWord As String
  Dim blnVerify As Boolean
  Dim blnRef As Boolean
  Dim strReply As String
  On Error GoTo OH_NO
  strKeyWord = "Yes No"
  ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
  strReply = ThisDrawing.Utility.GetKeyword(vbCrLf _
  & "Verify each name to be purged? [Yes/No] <Y>: ")
  If strReply = "Yes" Then
    blnVerify = True
  ElseIf strReply = "" Then
    blnVerify = True
  Else
    blnVerify = False
  End If
  Set objSelCol = ThisDrawing.SelectionSets
  Set objLTCol = ThisDrawing.Linetypes
  Set objLayers = ThisDrawing.Layers
  For Each objSelSet In objSelCol
    If objSelSet.Name = "purgelts" Then
      ThisDrawing.SelectionSets.Item("purgelts").Delete
      Exit For
    End If
  Next
  For Each objLT In objLTCol
    If StrComp(objLT.Name, "BYLAYER", vbTextCompare) <> 0 And _
    StrComp(objLT.Name, "BYBLOCK", vbTextCompare) <> 0 And _
    StrComp(objLT.Name, "CONTINUOUS", vbTextCompare) <> 0 Then
      Set objSelSet = ThisDrawing.SelectionSets.Add("purgelts")
      intType(0) = 6
      varData(0) = objLT.Name
      objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, _
      filterdata:=varData
      If objSelSet.Count = 0 Then
        blnRef = False
        For Each objLayer In objLayers
          If objLayer.Linetype = objLT.Name Then
            blnRef = True
            Exit For
          End If
        Next
        If Not blnRef Then
          If blnVerify Then
            ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
            strReply = ThisDrawing.Utility.GetKeyword(vbCrLf & "Purge " _
            & objLT.Name & " [Yes/No] <Y>: ")
              If strReply = "Yes" Then
                objLT.Delete
              ElseIf strReply = "" Then
                objLT.Delete
              End If
          Else
            objLT.Delete
          End If
        End If
      End If
      ThisDrawing.SelectionSets.Item("purgelts").Delete
    End If
  Next
Exit_Here:
  Exit Sub
OH_NO:
  ThisDrawing.Utility.Prompt vbCrLf & Err.Description
  Resume Exit_Here
End Sub
'End PurgeLTs

Удаление из базы данных чертежа неиспользуемых слоев.

'Begin PurgeLayers
Public Sub PurgeLayers()
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objLayrCol As AcadLayers
  Dim objLayr As AcadLayer
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Dim strKeyWord As String
  Dim blnVerify As Boolean
  Dim strReply As String
  On Error GoTo OH_NO
  strKeyWord = "Yes No"
  ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
  strReply = ThisDrawing.Utility.GetKeyword(vbCrLf _
  & "Verify each name to be purged? [Yes/No] <Y>: ")
  If strReply = "Yes" Then
   blnVerify = True
  ElseIf strReply = "" Then
    blnVerify = True
  Else
    blnVerify = False
  End If
  Set objSelCol = ThisDrawing.SelectionSets
  Set objLayrCol = ThisDrawing.Layers
  For Each objSelSet In objSelCol
    If objSelSet.Name = "purgelayers" Then
      ThisDrawing.SelectionSets.Item("purgelayers").Delete
      Exit For
    End If
  Next
  For Each objLayr In objLayrCol
    If StrComp(objLayr.Name, ThisDrawing.ActiveLayer.Name) <> 0 Then
      Set objSelSet = ThisDrawing.SelectionSets.Add("purgelayers")
      intType(0) = 8
      varData(0) = objLayr.Name
      objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, _
      filterdata:=varData
      If objSelSet.Count = 0 Then
        If blnVerify Then
          ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
          strReply = ThisDrawing.Utility.GetKeyword(vbCrLf & "Purge " _
          & objLayr.Name & " [Yes/No] <Y>: ")
          If strReply = "Yes" Then
            objLayr.Delete
          ElseIf strReply = "" Then
            objLayr.Delete
          End If
        Else
          objLayr.Delete
        End If
      End If
      ThisDrawing.SelectionSets.Item("purgelayers").Delete
    End If
  Next
Exit_Here:
  Exit Sub
OH_NO:
  ThisDrawing.Utility.Prompt vbCrLf & Err.Description
  Resume Exit_Here
End Sub
'End PurgeLayers

Удаление из базы данных чертежа неиспользуемых блоков, слоев или типов линий по выбору

Public Sub PurgeThis()
  Dim strReply As String
  Dim strKeys As String
  Dim strPrompt As String
  strKeys = "Blocks LAyers LTypes All"
  strPrompt = vbCrLf & "Enter type of unused objects to purge" _
  & vbCrLf & "Blocks/LAyers/LTypes/All: "
  ThisDrawing.Utility.InitializeUserInput 1, strKeys
  strReply = ThisDrawing.Utility.GetKeyword(strPrompt)
  Select Case strReply
    Case "Blocks"
     Call PurgeBlocks
    Case "LAyers"
      Call PurgeLayers
    Case "LTypes"
      Call PurgeLTs
    Case "All"
      Call PurgeBlocks
      Call PurgeLayers
      Call PurgeLTs
    Case Else
      Debug.Print strReply
      ' I want to know what snuck in!
    End Select
End Sub

Удаление из базы данных чертежа неиспользуемых групп объектов

Public Sub GroupPurge()
   Dim groupset As AcadGroups
   Dim groupdead As AcadGroup
   Dim test As Integer
   Dim i As Long, h As Long

   DoEvents
   i = ThisDrawing.Groups.Count
   If i > 2000 Then
      test = MsgBox("This may take several minutes.", _
             vbOKCancel, "Information")
   End If
   If test = 2 Then
      End
   End If
   Set groupset = ThisDrawing.Groups
   For h = i - 1 To 0 Step -1
      DoEvents
      Set groupdead = groupset.Item(h)
      If groupdead.Count = 0 Then
         groupdead.Delete
      End If
   Next h
End Sub

Очистка базы данных чертежа от всех неиспользуемых элементов с помощью диалогового окна.

В пакет входит пример диалогового окна с запросом на удаление вышеперечисленных элементов.
Поместите следующий код в стандартный модуль:

Option Explicit

Public Sub PurgeLineTypes()
  Dim objLTs As AcadLineTypes
  Dim objLT As AcadLineType
  On Error GoTo Err_Control
  Set objLTs = ThisDrawing.Linetypes
  For Each objLT In objLTs
    objLT.Delete
  Next objLT
Exit_Here:
  Exit Sub
Err_Control:
  If Err.Number = -2145320931 Then
    Resume Next
  Else
    MsgBox Err.Description
    Resume Exit_Here
  End If
End Sub

Public Sub PurgeLayers()
  Dim objLyrs As AcadLayers
  Dim objLyr As AcadLayer
  On Error GoTo Err_Control
  Set objLyrs = ThisDrawing.Layers
  For Each objLyr In objLyrs
    objLyr.Delete
  Next objLyr
Exit_Here:
  Exit Sub
Err_Control:
  If Err.Number = -2145320931 Then
    Resume Next
  Else
    MsgBox Err.Description
    Resume Exit_Here
  End If
End Sub

Public Sub PurgeTextStyles()
  Dim objStyles As AcadTextStyles
  Dim objStyle As AcadTextStyle
  On Error GoTo Err_Control
  Set objStyles = ThisDrawing.TextStyles
  For Each objStyle In objStyles
    objStyle.Delete
  Next objStyle
Exit_Here:
  Exit Sub
Err_Control:
  If Err.Number = -2145320931 Then
    Resume Next
  Else
    MsgBox Err.Description
    Resume Exit_Here
  End If
End Sub

Public Sub PurgeDimStyles()
  Dim objStyles As AcadDimStyles
  Dim objStyle As AcadDimStyle
  On Error GoTo Err_Control
  Set objStyles = ThisDrawing.DimStyles
  For Each objStyle In objStyles
    objStyle.Delete
  Next objStyle
Exit_Here:
  Exit Sub
Err_Control:
  If Err.Number = -2145320931 Then
    Resume Next
  Else
    MsgBox Err.Description
    Resume Exit_Here
  End If
End Sub

Для тестирования процедур создайте диалоговое окно с двумя кнопками и четырьмя чекбоксами. Поместите в модуль формы следующий код:

Private Sub UserForm_Initialize()
  Frame1.Caption = "Items to Purge"
  CheckBox1.Caption = "Dimension Styles"
  CheckBox1.Tag = 3
  CheckBox2.Caption = "Layers"
  CheckBox2.Tag = 8
  CheckBox3.Caption = "Line Types"
  CheckBox3.Tag = 6
  CheckBox4.Caption = "Text Styles"
  CheckBox4.Tag = 7
  CommandButton1.Caption = "Purge"
  CommandButton2.Caption = "Exit"
  Me.Caption = "Purge Drawing Options"
End Sub

Private Sub CommandButton1_Click()
  Dim objControl As Control
  For Each objControl In Me.Controls
    If TypeOf objControl Is CheckBox Then
      If objControl.Value = True Then
        Purge objControl.Tag
      End If
    End If
  Next objControl
End Sub

Private Sub CommandButton2_Click()
  Unload Me
End Sub

Public Sub Purge(intFilter As Integer)
  Select Case intFilter
  Case 3
    Call PurgeDimStyles
  Case 6
    Call PurgeLineTypes
  Case 7
    Call PurgeTextStyles
  Case 8
    Call PurgeLayers
  Case Else
    ' Eh?
  End Select
End Sub

Для запуска формы добавьте в стандартный модуль следующий код:

Private Sub TEST_Purge()
  UserForm1.Show
End Sub

Команда Trim (Обрезка)

Обрезка одной линии по другой

Кроме основной процедуры здесь использована вспомогательная функция GetLength, определяющая длину отрезка, соединяющего две заданные точки

Public Sub HowToTrim()
  Dim objEnt As AcadEntity
  Dim objCut As AcadLine
  Dim objTrim As AcadLine
  Dim varPnt As Variant
  Dim varSPnt As Variant
  Dim varEPnt As Variant
  Dim strPrmpt As String
  Dim varTrimPnt As Variant
  Dim dblTrimPnt(2) As Double
  Dim varInterSectns As Variant

  On Error GoTo Err_Control
  strPrmpt = vbCrLf & "Select Cutting edge"
  ThisDrawing.Utility.GetEntity objCut, varPnt, strPrmpt
  objCut.Highlight True
  Do
    strPrmpt = vbCrLf & "Line to trim: "
    ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmpt
    If TypeOf objEnt Is AcadLine Then
      Set objTrim = objEnt
      varInterSectns = objTrim.IntersectWith(objCut, acExtendNone)
      If IsArray(varInterSectns) Then
        If UBound(varInterSectns) > 0 Then
          varSPnt = objTrim.StartPoint
          varEPnt = objTrim.EndPoint
          dblTrimPnt(0) = varInterSectns(0)
          dblTrimPnt(1) = varInterSectns(1)
          dblTrimPnt(2) = varInterSectns(2)
          varTrimPnt = Array(varInterSectns(0), _
          varInterSectns(1), varInterSectns(2))
          If GetLength(varSPnt, varPnt) > _
          GetLength(varSPnt, varTrimPnt) Then
            objTrim.EndPoint = dblTrimPnt
          Else
            objTrim.StartPoint = dblTrimPnt
          End If
        End If
      End If
    End If
  Loop
Exit_here:
  If Not objCut Is Nothing Then
    objCut.Highlight False
  End If
  Exit Sub
Err_Control:
  ' If they select anything other than A line
  If Err.Description = "Type mismatch" Then
    Err.Clear
    Resume
  Else
    ' I leave it to you to choose your method of
    ' Error handling for the "GetEntity method failed"
    ' Error (see articles on Check key or the ERRNO
    ' Variable
    Debug.Print Err.Description
    Resume Exit_here
  End If
End Sub

Public Function GetLength(varStart As Variant, varEnd As Variant) As Double
  Dim dblLen As Double

  On Error GoTo Err_Control
  dblLen = Sqr((varStart(0) - varEnd(0)) ^ 2 + _
  (varStart(1) - varEnd(1)) ^ 2 + _
  (varStart(2) - varEnd(2)) ^ 2)
  GetLength = dblLen
Exit_here:
  Exit Function
Err_Control:
  MsgBox Err.Description
End Function

Команда Zoom (Масштабирование)

Пример функции, масштабирующей изображение по габаритам заданного примитива.

'@~~~~~~~~~~~~~~~~ vbdBoundingBox ~~~~~~~~~~~~~~~~~~@
' From the Llama Library, this is used in the example
' To Zoom into the block!
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function vbdBoundingBox(objEntity As Object) As Variant
  Dim varMin As Variant
  Dim varMax As Variant
  objEntity.GetBoundingBox varMin, varMax
  vbdBoundingBox = Array(varMin, varMax)
End Function

Public Sub TEST_vbdBoundingBox()
    Dim AE As AcadEntity
    Dim varPT As Variant
    Dim varZoomWindow As Variant

    ThisDrawing.Utility.GetEntity AE, varPT, "Выберите объект: "
    varZoomWindow = vbdBoundingBox(AE)

    Application.ZoomWindow varZoomWindow(0), varZoomWindow(1)
End Sub