AutoCAD VBA Code Examples Команды AutoCAD WWW.CAD.DP.UA

Команды 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

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 (Поворот)

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

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

Определяется содержимое текстового объекта.
Если содержимое текстового объекта является числом, то 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

' Проверка наличия в чертеже слоя с заданнымn именем
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) Asm 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

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

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

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

Добавьте в проект форму, создайте в ней один список (ListBox) и две командные кнопки (CommandButton). У Вас должно получиться что-то похожее на это:

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

'@~~~~~~~~~~~ Begin Code Block ~~~~~~~~~~~~@
' USER FORM

Option Explicit
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' A single API to slow down the loop when
' Making the block "Flash"
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Public variables for the selected block
' Selection set and a boolean for turning
' the flash on and off
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Dim objBlkSet As AcadSelectionSet
Dim objBlkRef As AcadBlockReference
Private blnFlash As Boolean

Private Sub CommandButton1_Click()
  ZoomAll
End Sub
 
Private Sub CommandButton2_Click()
  Unload Me
End Sub

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' When you click an item if its not flashing
' it will, if it is flashing it will stop.
' However after you turn it off you will not
' be able to turn it back on for that block
' without selecting something else first.
' Do you know why?
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Private Sub ListBox1_Click()
 Dim intCnt As Integer
  For intCnt = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(intCnt) Then
      Set objBlkRef = objBlkSet.Item(intCnt)
      blnFlash = True
      Exit For
    End If
  Next intCnt
End Sub
 
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  Call ZoomObject(objBlkRef)
End Sub
 
Private Sub ListBox1_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  blnFlash = False
End Sub

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' The checks are not really needed, but
' it doesn't hurt to check for valid
' objects and button clicks
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Private Sub ListBox1_MouseUp(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Not objBlkRef Is Nothing Then
    If Button = 1 Then
      Call Flash(objBlkRef)
    End If
  End If
End Sub

Private Sub UserForm_Initialize()
  Dim varDat(0) As Variant
  Dim intDat(0) As Integer
  varDat(0) = "INSERT"
  intDat(0) = 0
  Set objBlkSet = vbdPowerSet("blocks")
  objBlkSet.Select Mode:=acSelectionSetAll, Filtertype:=intDat, _
                         filterdata:=varDat
  For Each objBlkRef In objBlkSet
    ListBox1.AddItem objBlkRef.Name
  Next objBlkRef
  CommandButton1.Caption = "Zoom All"
  CommandButton2.Caption = "Exit"
  Me.Caption = "Block Finder"
End Sub

'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' You will never have to worry about your
' Selection set name again.
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
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
 
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' The Flash procedure uses DoEvents to
' allow all other events to be processed.
' I wrapped the Sleep in a check for exit
' for faster responce and unload.
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Private Sub Flash(acObject As AcadEntity)
  Do
    acObject.Highlight True
    acObject.Update
    DoEvents
    If blnFlash Then
      Sleep 500
    Else
      Exit Do
    End If
    acObject.Highlight False
    acObject.Update
    DoEvents
    If blnFlash Then
      Sleep 500
    Else
      Exit Do
    End If
  Loop
  acObject.Highlight False
  acObject.Update
End Sub
 
Private Sub ZoomObject(acObject As Object)
  Dim varBox As Variant
  blnFlash = False
  varBox = vbdBoundingBox(acObject)
  Application.ZoomWindow varBox(0), varBox(1)
End Sub
 
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Returns the bounding box of any item.
' Used here to get our zoom window.
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
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
 
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' If the user clicks that little x we need
' to force an exit from the flash routine
' loop. General clean up as well
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  blnFlash = False
  Set objBlkRef = Nothing
  If Not objBlkSet Is Nothing Then
    ThisDrawing.SelectionSets.Item("blocks").Delete
  End If
End Sub

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

'@~~~~~~~~~~~ Begin Code Block ~~~~~~~~~~~~@
' Standart Module

Option Explicit

Public Sub TestIt ()
  UserForm1.Show
End Sub

Вставьте в чертеж несколько блоков и запустите процедуру TestIt. При запуске формы список будет заполнен именами вставленных блоков, и при двойном щелчке по любому из них изображение будет масштабировано таким образом, что выбранный блок будет отображен на весь экран.

						Translate to:
Обратная связь	Новости САПР	Программы	Документация	Полезные советы	Обзорные статьи
Заказ и разработка	Каталог САПР	САПР-конференция	Библиотека ГОСТов	Наши соавторы	Коммерческое ПО