Реклама в Интернет

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