AutoCAD VBA Code Examples Примитивы чертежей AutoCAD (часть 1) WWW.CAD.DP.UA

Примитивы чертежей AutoCAD

Пример создания класса для работы с примитивами AutoCAD

Сейчас мы попробуем создать класс объекта, который позволит нам задавать параметры и получать значения свойств отрезка. Создайте VBA проект, добавте в него модуль класса. Задайте этому модулю класса имя "imaLine".

Добавим в класс два свойства Начальную точку (StartPoint) и Конечную точку (EndPoint). Для этого опишем две переменные в разделе General Declarations модуля класса и добавим соответствующие функции:

Private vStart As Variant
Private vEnd As Variant

Public Property Let StartPoint(varPnt As Variant)
 If IsArray(varPnt) Then
     If UBound(varPnt) = 2 Then
       vStart = varPnt
    End If
  End If
End Property

Public Property Get StartPoint() As Variant
   StartPoint = vStart
End Property

Public Property Let EndPoint(varPnt As Variant)
  If IsArray(varPnt) Then
    If UBound(varPnt) = 2 Then
      vEnd = varPnt

    End If
  End If
End Property

Public Property Get EndPoint() As Variant
  EndPoint = vEnd
End Property

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

Public Sub NotARealLine()
  Dim objLine As New imaLine
  Dim varSPnt As Variant
  Dim varEPnt As Variant
  Dim strPrmt As String
  strPrmt = vbCrLf & "Select Point: "
  varSPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrmt)
  varEPnt = ThisDrawing.Utility.GetPoint(varSPnt, strPrmt)
  objLine.StartPoint = varSPnt
  objLine.EndPoint = varEPnt
  Debug.Print objLine.StartPoint(0)
  Debug.Print objLine.EndPoint(0)
  Set objLine = Nothing
End Sub

Теперь, если Вы запустите процедуру NotARealLine и укажете две точки, то будет создан объект objLine как экземпляр класса imaLine, его свойствам будут присвоены указанные Вами точки, Х координаты которых будут напечатаны в окне Immediate.

"Ну и что с того?" - спросите Вы. И правильно спросите. Пока ничего. Надо еще доработать наш класс. Добавим в него свойство Lenght, определяющее длину линии. Это будет свойство "Только для чтения", поэтому процедура Property Let не нужна. Чтобы создать свойство Lenght добавте в модуль класса следующий код:

 
Public Property Get Length() As Double
  Dim dblLen As Double
  On Error GoTo Err_Control
  dblLen = Sqr((vStart(0) - vEnd(0)) ^ 2 + _
  (vStart(1) - vEnd(1)) ^ 2 + _
  (vStart(2) - vEnd(2)) ^ 2)
  Length = dblLen
Exit_here:
  Exit Property
Err_Control:
  Err.Raise 1004, Description:="Line not defined."
  Resume Exit_here
End Property

Подправим наш код в модуле ThisDrawing и опять запустим процедуру NotARealLine

Public Sub NotARealLine()
  Dim objLine As New imaLine
  Dim varSPnt As Variant
  Dim varEPnt As Variant
  Dim strPrmt As String
  strPrmt = vbCrLf & "Select Point: "
  varSPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrmt)
  varEPnt = ThisDrawing.Utility.GetPoint(varSPnt, strPrmt)
  objLine.StartPoint = varSPnt
  objLine.EndPoint = varEPnt
  Debug.Print objLine.StartPoint(0)
  Debug.Print objLine.EndPoint(0)
  MsgBox objLine.Length  ' Это новая строка
  Set objLine = Nothing
End Sub

Теперь наш класс не только занимает место на диске в виде программного кода, но и выполняет полезную работу. Вычисляет длину между указанными точками.

А представьте, ведь в этот класс можно добавить, например, метод DrawLine (Отрисовать линию). Давайте попробуем. Добавьте в модуль класса следующий код:

Public Sub DrawLine()
  On Error GoTo Err_Control
  
  ' Определяем текущее пространство
  If ThisDrawing.ActiveSpace = acModelSpace Then
    ' Рисуем в пространстве модели
    ThisDrawing.ModelSpace.AddLine vStart, vEnd
  Else
    ' Рисуем в пространстве листа
    ThisDrawing.PaperSpace.AddLine vStart, vEnd
  End If
Exit_here:
  Exit Sub
Err_Control:
  Err.Raise 1004, Description:="Line not defined."
  Resume Exit_here
End Sub

Снова подправим наш код в модуле ThisDrawing и опять запустим процедуру NotARealLine

 
Public Sub NotARealLine()
  Dim objLine As New imaLine
  Dim varSPnt As Variant
  Dim varEPnt As Variant
  Dim strPrmt As String
  strPrmt = vbCrLf & "Select Point: "
  varSPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrmt)
  varEPnt = ThisDrawing.Utility.GetPoint(varSPnt, strPrmt)
  objLine.StartPoint = varSPnt
  objLine.EndPoint = varEPnt
  Debug.Print objLine.StartPoint(0)
  Debug.Print objLine.EndPoint(0)
  MsgBox objLine.Length
  objLine.DrawLine   ' Это новая строка
  Set objLine = Nothing
End Sub

Теперь мы не только получаем информацию о длине нашей линии, но и отрисовываем ее

А можно пойти и дальше, создать свойства MidPoint (Средняя точка), LineType (Тип линии, задающий собственно Тип линии, ее толщину и цвет). И это далеко не все, что можно придумать.

Можно создать класс Кольцевой сектор, со всевозможными свойствами типа Радиуса, Площадь, Периметр. И, естественно, с методом DrawSector...

Как Вам простор для деятельности?

Выбор объектов

Процедура сохранения всех объектов с заданного слоя в отдельном чертеже.

'**** PLEASE NOTE *******
'If a drawing with the same path & name exists
'This WILL over write it!

Public Sub WBlockLayer(LayerName As String)
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Dim strPath As String
  On Error GoTo Err_Control
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = "wblocklayer" Then
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = objSelCol.Add("wblocklayer")
  intType(0) = 8
  varData(0) = LayerName
  objSelSet.Select 5, filtertype:=intType, _
  filterdata:=varData
  If objSelSet.Count > 0 Then
    strPath = ThisDrawing.Path & "\"
    strPath = strPath & LayerName & ".dwg"
    ThisDrawing.Wblock strPath, objSelSet
  Else
    MsgBox "Nothing found on layer " & LayerName
  End If
  Set objSelCol = Nothing
  Set objSelSet = Nothing
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

Работа с SelectionSet (Набор объектов)

Добавление объектов в набор путем указания мышью
Определение количества объектов в наборе
Удаление набора

Public Sub AddEntToSS()
  Dim acSelSet As AcadSelectionSet
  Dim intCnt As Integer
  Dim objArray(0) As Object
  Dim AnyObj As AcadEntity
  Dim AnyPnt As Variant
  Set acSelSet = ThisDrawing.SelectionSets.Add("test")
  acSelSet.SelectOnScreen
  intCnt = acSelSet.Count
  MsgBox "There are " & intCnt & _
  " Entities in the new Selection Set"
  ThisDrawing.Utility.GetEntity AnyObj, AnyPnt, _
  "Pick an Entity to Add to the Selection Set: "
  Set objArray(0) = AnyObj
  acSelSet.AddItems objArray
  intCnt = acSelSet.Count
  MsgBox "Now there are " & intCnt & _
  " Entities in the new Selection Set"
    ThisDrawing.SelectionSets.Item("test").Delete
End Sub

Проверка, есть ли в заданной точке текстовый объект

Перед запуском процедуры создайте в текущем чертеже текстовый объект в точке X = -1.75, Y = 1.063, Z = 0. Функция вернет содержимое текстового объекта.

Public Function TextLocatedFromPoint(varPoint As Variant) As String
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Set objSelCol = ThisDrawing.SelectionSets
  For Each objSelSet In objSelCol
    If objSelSet.Name = "TextFromPoint" Then
      objSelSet.Delete
      Exit For
    End If
  Next
  intType(0) = 0
  varData(0) = "TEXT"
  Set objSelSet = ThisDrawing.SelectionSets.Add("TextFromPoint")
  objSelSet.SelectAtPoint varPoint, intType, varData
  If objSelSet.Count > 0 Then
    TextLocatedFromPoint = objSelSet.Item(0).TextString
  End If
End Function

Public Sub Test_TextLocatedFromPoint ()
  'Hi Deb,
  'Assumes that your dumb text is
  'located at X = -1.75, Y = 1.063
  'And Z = 0
  Dim strPrmt As String
  Dim varPnt As Variant
  'Note the use of late binding?
  'A must if you want to use the
  'CreateTypedArray function!
  Dim objUtil As Object
  Set objUtil = ThisDrawing.Utility
  objUtil.CreateTypedArray varPnt, vbDouble, -1.75, 1.063, 0
  strPrmt = TextLocatedFromPoint(varPnt)
  If Len(strPrmt) > 0 Then
    MsgBox strPrmt
  Else
    MsgBox "Could not locate text."
  End If
End Sub

Получение набора объектов, пересекающихся с выбранной линией

Public Function SelectByIntersection(objEnt As AcadEntity) As AcadSelectionSet
  Dim objGen As AcadEntity
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objArray() As Object
  Dim strName As String
  Dim varMin As Variant
  Dim varMax As Variant
  Dim varIntPnt As Variant
  Dim intcnt As Integer

  On Error GoTo Err_Control

  objEnt.GetBoundingBox varMin, varMax
  strName = "vbdintersect"
  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)
  objSelSet.Select acSelectionSetCrossing, varMin, varMax
  For Each objGen In objSelSet
    varIntPnt = objEnt.IntersectWith(objGen, acExtendNone)
    If UBound(varIntPnt) = -1 Then
      ReDim Preserve objArray(intcnt)
      Set objArray(intcnt) = objGen
      intcnt = intcnt + 1
    End If
    varIntPnt = Empty
  Next
  If IsEmpty(objArray) Then
    Set SelectByIntersection = objSelSet
  Else
    objSelSet.RemoveItems objArray
    Set SelectByIntersection = objSelSet
  End If
Exit_Here:
  Exit Function
  MsgBox Err.Description
  Resume Exit_Here
End Function

‘A Very simple (and pointless) test

Public Sub TEST_SelectByIntersection ()
  Dim objSS As AcadSelectionSet
  Dim objToCheck As AcadEntity
  Dim varPnt As Variant
  Dim objThatIntersects As AcadEntity
  ThisDrawing.Utility.GetEntity objToCheck, varPnt, "Select an object: "
  Set objSS = SelectByIntersection(objToCheck)
  For Each objThatIntersects In objSS
    objThatIntersects.Highlight True
  Next
  If MsgBox("Выбранный объект пересекает " & CStr(objSS.Count) & _
            " объектов." & vbCrLf & "Удалить эти объекты?", _
            vbQuestion + vbYesNo, "TEST_SelectByIntersection") = vbYes Then
    For Each objThatIntersects In objSS
      objThatIntersects.Delete
    Next
  Else
      For Each objThatIntersects In objSS
        objThatIntersects.Highlight False
      Next
  End If
End Sub

Определение габаритов группы выбранных объектов

После запуска процедуры выберите несколько объектов и изображение будет масштабировано по их габаритам.

'@~~~~ Get the bounding box of a selection set ~~~~@
Public Function GetSSBoundingBox(Min As Variant, _
Max As Variant, objSet As AcadSelectionSet) As Boolean
  Dim dblMaxX As Double
  Dim dblMaxY As Double
  Dim dblMinX As Double
  Dim dblMinY As Double
  Dim varMin As Variant
  Dim varMax As Variant
  Dim objEnt As AcadEntity
  Dim objUtil As Object
  On Error GoTo Err_Control
  Set objUtil = ThisDrawing.Utility
  objSet.Item(0).GetBoundingBox varMin, varMax
  dblMinX = varMin(0)
  dblMinY = varMin(1)
  dblMaxX = varMax(0)
  dblMaxY = varMax(1)
  'Get the highs and lows
  For Each objEnt In objSet
    objEnt.GetBoundingBox varMin, varMax
    If varMin(0) < dblMinX Then
      dblMinX = varMin(0)
    End If
    If varMin(1) < dblMinY Then
      dblMinY = varMin(1)
    End If
    If varMax(0) > dblMaxX Then
      dblMaxX = varMax(0)
    End If
    If varMax(1) > dblMaxY Then
      dblMaxY = varMax(1)
    End If
  Next objEnt
  'Fill the arrays
  objUtil.CreateTypedArray Min, vbDouble, dblMinX, dblMinY, 0
  objUtil.CreateTypedArray Max, vbDouble, dblMaxX, dblMaxY, 0
  GetSSBoundingBox = True
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function


Public Sub Test_GetSSBoundingBox()
  Dim acSelSet As AcadSelectionSet
  Dim varMin As Variant
  Dim varMax As Variant
  Dim dblPnts(0 To 5) As Double

  Set acSelSet = ThisDrawing.SelectionSets.Add("TestGetSSBB")
  acSelSet.SelectOnScreen
  GetSSBoundingBox varMin, varMax, acSelSet
  ZoomWindow varMin, varMax
End Sub

Использование фильтра для выбора объектов.

При запуске этой процедуры будут выбраны только текстовые объекты

Public Function SelectTextOnScreen() As AcadSelectionSet
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim intDXF(3) As Integer
  Dim varVal(3) As Variant
  Set objSelCol = ThisDrawing.SelectionSets
  For Each objSelSet In objSelCol
    If objSelSet.Name = "Textonly" Then
      objSelSet.Delete
      Exit For
    End If
  Next
  Set objSelSet = ThisDrawing.SelectionSets.Add("Textonly")
  intDXF(0) = -4
  varVal(0) = "<OR"
  intDXF(1) = 0
  varVal(1) = "MTEXT"
  intDXF(2) = 0
  varVal(2) = "TEXT"
  intDXF(3) = -4
  varVal(3) = "OR>"
  objSelSet.SelectOnScreen intDXF, varVal
  Set SelectTextOnScreen = objSelSet
End Function

Public Sub TEST_SelectTextOnScreen()
  Dim acSelSet As AcadSelectionSet
  Dim varMin As Variant
  Dim varMax As Variant
  Dim dblPnts(0 To 5) As Double
  Dim objAcEntity As AcadEntity

  Set acSelSet = SelectTextOnScreen
  MsgBox "Найдено " & CStr(acSelSet.Count) & " текстовых объектов"
End Sub

Обеспечение фильтра выбора объектов

Перед запуском процедуры создайте в чертеже три слоя Prova1, Prova2 и Prova3. Разместите по несколько объектов на каждом из этих слоев. После запуска процедуры будут выбраны только те объекты, которые не находятся на слоях Prova1 и Prova2

Public Sub FilterSet()
  Dim objSelSet As AcadSelectionSet
  Dim objEnt As AcadEntity
  Dim intType(0 To 7) As Integer
  Dim varData(0 To 7) As Variant
  intType(0) = -4
  intType(1) = -4
  intType(2) = 8
  intType(3) = -4
  intType(4) = -4
  intType(5) = 8
  intType(6) = -4
  intType(7) = -4
  varData(0) = "<AND"
  varData(1) = "<NOT"
  varData(2) = "Prova1"
  varData(3) = "NOT>"
  varData(4) = "<NOT"
  varData(5) = "Prova2"
  varData(6) = "NOT>"
  varData(7) = "AND>"
  Set objSelSet = ThisDrawing.SelectionSets.Add("sample")
  objSelSet.Select acSelectionSetAll, Filtertype:=intType, filterdata:=varData
  For Each objEnt In objSelSet
    objEnt.Highlight True
  Next
  ThisDrawing.SelectionSets.Item("sample").Delete
End Sub

Использование меток для создания набора

Public Function SelectByHandle(acSelSet As AcadSelectionSet, _
vHandles As Variant) As Integer
  Dim intCnt As Integer
  Dim objArray() As AcadEntity
  On Error GoTo Err_Control
  ReDim objArray(UBound(vHandles))
  For intCnt = LBound(vHandles) To UBound(vHandles)
    Set objArray(intCnt) = ThisDrawing.HandleToObject(vHandles(intCnt))
  Next intCnt
  acSelSet.AddItems objArray
Exit_Here:
  SelectByHandle = intCnt
  Exit Function
Err_Control:
  Debug.Print Err.Description
  Resume Exit_Here
End Function

Отслеживание выбора пользователем примитивов

Если переменная blnOn равна True, то при выборе пользователем в чертеже примитива будет возникать диалоговое окно с информацией об объекте.

Private blnOn As Boolean

Private Sub AcadDocument_SelectionChanged()
  Dim strType As String
  Dim strLayer As String
  Dim intColor As Integer
  Dim objGen As AcadEntity
  If blnOn Then
    If ThisDrawing.PickfirstSelectionSet.Count > 0 Then
      Set objGen = ThisDrawing.PickfirstSelectionSet.Item(0)
      intColor = objGen.Color
      strType = objGen.ObjectName
      strLayer = objGen.Layer
      MsgBox "The selected object is an " & strType & vbCr & _
      "Color = " & intColor & vbCr & "Layer = " & strLayer
    End If
  End If
End Sub

Public Sub On_Off()
  blnOn = Not blnOn
End Sub

Изменение свойств объектов

Изменения цвета объектов с помощью диалогового окна,
вызываемого из файла ACAD.EXE

В этом примере используется вызов функции acedSetColorDialog из файла acad.exe.

Option Explicit

Private Declare Function acedSetColorDialog Lib _
"acad.exe" (color As Long, ByVal bAllowMetaColor _
As Boolean, ByVal nCurLayerColor As Long) As Boolean

Private Function ChooseColor(ByVal lngInitClr As Long, _
ByVal blnMetaColor As Boolean, ByVal _
lngCurClr As Long) As Long
  ChooseColor = -1
  On Error Resume Next
  If acedSetColorDialog(lngInitClr, _
    blnMetaColor, lngCurClr) Then
    ChooseColor = lngInitClr
  End If
End Function


Public Sub TEST_ChangeColor()
  Dim objEnt As AcadEntity
  Dim varPnt As Variant
  Dim strPrmt As String
  On Error GoTo Err_Control
  strPrmt = vbCr & "Select an entity: "
  ThisDrawing.Utility.GetEntity objEnt, _
  varPnt, strPrmt
  objEnt.color = ChooseColor(objEnt.color, _
  True, objEnt.color)
Exit_Here:
  Exit Sub
Err_Control:
  Debug.Print Err.Description
  Resume Exit_Here
End Sub

Отрезки

Определение длины выбранного отрезка

Public Function LineLength(oLine As AcadLine) As Double
  Dim dblLen As Double
  Dim varStart As Variant
  Dim varEnd As Variant
  On Error GoTo Err_Control
  varStart = oLine.StartPoint
  varEnd = oLine.EndPoint
  dblLen = Sqr((varStart(0) - varEnd(0)) ^ 2 + _
  (varStart(1) - varEnd(1)) ^ 2 + _
  (varStart(2) - varEnd(2)) ^ 2)
  LineLength = dblLen
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
End Function

Sub TEST_LineLength()
  Dim objAcEnt As AcadEntity
  Dim varSelPt As Variant
  Dim objAcLine As AcadLine
  
  On Error GoTo Err_Handler
  ThisDrawing.Utility.GetEntity objAcEnt, varSelPt, "Выберите линию: "
  Do While Not objAcEnt Is Nothing
    If objAcEnt.ObjectName = "AcDbLine" Then
      Set objAcLine = objAcEnt
      MsgBox "Длина выбранной линии равна " & CStr(LineLength(objAcLine))
    Else
      MsgBox "Это не отрезок", vbExclamation
    End If
    ThisDrawing.Utility.GetEntity objAcEnt, varSelPt, "Выберите линию: "
  Loop
  Exit Sub
Err_Handler:
  Err.Clear
End Sub

Определение координат середины отрезка

Public Function LineMidPoint(Line As AcadLine) As Variant
  Dim varPnt1 As Variant
  Dim varPnt2 As Variant
  Dim varMidPnt As Variant
  varPnt1 = Line.StartPoint
  varPnt2 = Line.EndPoint
  varMidPnt = Array((varPnt1(0) + varPnt2(0)) / 2, _
  (varPnt1(1) + varPnt2(1)) / 2, (varPnt1(2) + varPnt2(2)) / 2)
  LineMidPoint = varMidPnt
End Function

Sub TEST_MidPoint()
  Dim objAcEnt As AcadEntity
  Dim varSelPt As Variant
  Dim objAcLine As AcadLine
  Dim varMPnt As Variant
  
  On Error GoTo Err_Handler
  ThisDrawing.Utility.GetEntity objAcEnt, varSelPt, "Выберите линию: "
  Do While Not objAcEnt Is Nothing
    If objAcEnt.ObjectName = "AcDbLine" Then
      Set objAcLine = objAcEnt
      varMPnt = LineMidPoint(objAcLine)
      MsgBox "Середина выбранного отрезка находится в" & vbCrLf & _
      "точке с координатами:" & vbCrLf & _
      "X = " & varMPnt(0) & ", Y = " & varMPnt(1) & ", Z = " & varMPnt(2)
    Else
      MsgBox "Это не отрезок", vbExclamation
    End If
    ThisDrawing.Utility.GetEntity objAcEnt, varSelPt, "Выберите линию: "
  Loop
  Exit Sub
Err_Handler:
  Err.Clear
End Sub

Процедура отрисовки двойной ломанной линии заданной ширины
через указываемые точки

'THE DOUBLE LINE METHOD BEGINS HERE 
Public Sub DoubleLine()
 Dim objUtil As AcadUtility
 Dim objNewLineA As AcadLine
 Dim objOldLineA As AcadLine
 Dim objNewLineB As AcadLine
 Dim objOldLineB As AcadLine
 Dim objSpace As AcadBlock
 Dim varPnt As Variant
 Dim varNext As Variant
 Dim dblWidth As Double
 Dim dblAngle As Double
 Dim strPrmt As String
 Dim varStart As Variant
 Dim varEnd As Variant
 Dim varCancel As Variant
 Dim varIntersect As Variant

 On Error GoTo Err_Control
 Set objUtil = ThisDrawing.Utility
 If ThisDrawing.ActiveSpace = acModelSpace Then
   Set objSpace = ThisDrawing.ModelSpace
 Else
   Set objSpace = ThisDrawing.PaperSpace
 End If
 strPrmt = vbCr &amp; "Width of double line: "
 dblWidth = objUtil.GetReal(strPrmt)
 strPrmt = vbCr & "First point: "
 varPnt = objUtil.GetPoint(Prompt:=strPrmt)
 Do
   strPrmt = vbCr & "Specify next point: "
   varNext = objUtil.GetPoint(varPnt, strPrmt)
   dblAngle = objUtil.AngleFromXAxis(varPnt, varNext)
   dblAngle = dblAngle + (90 / 180 * (Atn(1) * 4))
   varStart = objUtil.PolarPoint(varPnt, dblAngle, dblWidth)
   varEnd = objUtil.PolarPoint(varNext, dblAngle, dblWidth)
   Set objNewLineA = objSpace.AddLine(varStart, varEnd)
   If Not objOldLineA Is Nothing Then
     varIntersect = objNewLineA.IntersectWith(objOldLineA, _
     acExtendBoth)
     If UBound(varIntersect) = 2 Then
       objNewLineA.StartPoint = varIntersect
       objOldLineA.EndPoint = varIntersect
     End If
   End If
   Set objOldLineA = objNewLineA
   dblAngle = objUtil.AngleFromXAxis(varPnt, varNext)
   dblAngle = dblAngle - (90 / 180 * (Atn(1) * 4))
   varStart = objUtil.PolarPoint(varPnt, dblAngle, dblWidth)
   varEnd = objUtil.PolarPoint(varNext, dblAngle, dblWidth)
   Set objNewLineB = objSpace.AddLine(varStart, varEnd)
   If Not objOldLineB Is Nothing Then
     varIntersect = objNewLineB.IntersectWith(objOldLineB, _
     acExtendBoth)
     If UBound(varIntersect) = 2 Then
       objNewLineB.StartPoint = varIntersect
       objOldLineB.EndPoint = varIntersect
     End If
   End If
   Set objOldLineB = objNewLineB
   varPnt = varNext
 Loop
Exit_Here:
  Exit Sub
Err_Control:
  Select Case Err.Number
    Case -2147352567
      varCancel = ThisDrawing.GetVariable("LASTPROMPT")
      If InStr(1, varCancel, "*Cancel*") <> 0 Then
        Err.Clear
        Resume Exit_Here
      Else
      'Missed the pick, send them back!
        Err.Clear
        Resume
      End If
    Case -2145320928
    'Right click or enter
      Err.Clear
      Resume Exit_Here
    Case Else
      MsgBox Err.Description Err.Clear
      Resume Exit_Here
  End Select 
End Sub
'THE DOUBLE LINE CODE ENDS HERE

Размеры

Замена значениия размера его текстовым выражением

Процедура SelfOverRide заменяет значение размера его текстовым эквивалентом. Т.е. если текст размера равен "<>", и в чертеже отображается значение размера, например, 89,31, то процедура SelfOverRide заменит символы "<>" на символы "89,31"
К сожалению данный алгоритм работает только с линейными размерами.

Public Sub SelfOverRide(objDim As AcadDimension)
  Dim objBlk As AcadBlock
  Dim objEnt As AcadEntity
  Dim varPos As Variant
  Dim varInsPnt As Variant
  Dim objDimText As AcadMText
  Dim objBlocks As AcadBlocks
  Dim blnDone As Boolean
  Set objBlocks = ThisDrawing.Blocks
  varPos = objDim.TextPosition
  For Each objBlk In objBlocks
    If Not blnDone Then
      If Left(objBlk.Name, 2) = "*D" Then
        For Each objEnt In objBlk
          If TypeOf objEnt Is AcadMText Then
            Set objDimText = objEnt
            varInsPnt = objDimText.InsertionPoint
            If varInsPnt(0) = varPos(0) Then
              If varInsPnt(1) = varPos(1) Then
                objDim.TextOverride = objDimText.TextString
                blnDone = True
                Exit For
              End If
            End If
          End If
        Next objEnt
      End If
    Else
      Exit For
    End If
  Next objBlk
End Sub

Sub TEST_SelfOverRide()
    Dim strPrmt As String
    Dim objEnt As AcadEntity
    Dim varPnt As Variant
    Dim IsDimension As Boolean
    Dim objDim As AcadDimension
    
    On Error GoTo Err_Handler
    strPrmt = vbCr & "Выберите размер :"
    ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmt
    
    Set objDim = objEnt
    SelfOverRide objDim

    Exit Sub
Err_Handler:
    MsgBox Err.Number & vbCrLf & Err.Description
End Sub

Простановка вертикального или горизонтального линейного размера

Создайте в чертеже отрезок и добавьте в стандартный модуль следующий ниже код. Запустите процедуру TEST_DimLine_Horizontal_Vertical и на запрос "Выберите отрезок:" укажите созданный. Теперь осталось только указать местоположения размерных линий для вертикального и горизонтального размеров.

Option Explicit

Public Sub DimLine_Horizontal_Vertical(oLine As AcadLine, _
blnVert As Boolean, blnHorz As Boolean)
  Dim objHDim As AcadDimRotated
  Dim varStart As Variant
  Dim varPnt As Variant
  Dim varEnd As Variant
  Dim dblEnd(2) As Double
  Dim dblStart(2) As Double
  Dim dblDist As Double
  Dim dblLoc(2) As Double
  Dim strPrmpt As String
  
  On Error GoTo Err_Control
  varStart = oLine.StartPoint
  varEnd = oLine.EndPoint
  dblStart(0) = varStart(0)
  dblStart(1) = varStart(1)
  dblStart(2) = varStart(2)
  dblEnd(0) = varEnd(0)
  dblEnd(1) = varEnd(1)
  dblEnd(2) = varEnd(2)
  If blnVert Then
    strPrmpt = vbCrLf & "Select vertical dimension location: "
    varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrmpt)
    dblLoc(0) = varPnt(0)
    dblLoc(1) = varPnt(1)
    dblLoc(2) = varPnt(2)
    If ThisDrawing.ActiveSpace = acModelSpace Then
      Set objHDim = ThisDrawing.ModelSpace.AddDimRotated(dblStart, _
      dblEnd, dblLoc, 1.570796)
    Else
      Set objHDim = ThisDrawing.PaperSpace.AddDimRotated(dblStart, _
      dblEnd, dblLoc, 1.570796)
    End If
  End If
  If blnHorz Then
    strPrmpt = vbCrLf & "Select Horizontal dimension location: "
    varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrmpt)
    dblLoc(0) = varPnt(0)
    dblLoc(1) = varPnt(1)
    dblLoc(2) = varPnt(2)
    If ThisDrawing.ActiveSpace = acModelSpace Then
      Set objHDim = ThisDrawing.ModelSpace.AddDimRotated(dblStart, _
      dblEnd, dblLoc, 3.141592)
    Else
      Set objHDim = ThisDrawing.PaperSpace.AddDimRotated(dblStart, _
      dblEnd, dblLoc, 3.141592)
    End If
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

Public Sub TEST_DimLine_Horizontal_Vertical()
  Dim objLine As AcadEntity
  Dim varPnt As Variant
  
  On Error Resume Next
  ThisDrawing.Utility.GetEntity objLine, varPnt, _
  vbCrLf & "Выберите отрезок: "
  DimLine_Horizontal_Vertical objLine, True, True
End Sub

Группы объектов

Группировка примтивов по слоям

Поместите в стандартный модуль приведенный ниже код. Затем создайте в чертеже два слоя. Разместите на каждом из этих слоев по несколко примитивов POINT (ТОЧКА) и запустите процедуру GroupPntsByLayer. Точки будут сгруппированы по слоям и имена групп будут совпадать с именами слоев.

Public Sub GroupPntsByLayer()
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objEnts(0) As AcadEntity
  Dim objGrps As AcadGroups
  Dim objGroup As AcadGroup
  Dim objPoint As AcadPoint
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Dim strName As String
  On Error GoTo Err_Control
  Set objGrps = ThisDrawing.Groups
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = "pntsby" Then
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = objSelCol.Add("pntsby")
  intType(0) = 0
  varData(0) = "POINT"
  objSelSet.Select 5, filtertype:=intType, _
  filterdata:=varData
  For Each objPoint In objSelSet
    Set objEnts(0) = objPoint
    strName = objPoint.Layer
    'If it already exists this will bind
    'To the existing group.
    Set objGroup = objGrps.Add(strName)
    objGroup.AppendItems objEnts
  Next objPoint
  Set objSelSet = Nothing
  Set objGrps = Nothing
  Set objGroup = Nothing
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

Пороверка наличия в чертеже групппы с заданным именем

Пример функции, проверяющей, используется ли в текущем чертеже заданная строка как имя группы. Если заданное имя уже есть, то генерируется новое имя, которое в текущем чертеже еще не используется. Эта процедура необходима при программном создании новых групп объектов. После внесения очивидных изменений на базе этой функции можно создать анологичные функции для слоев, блоков стилей и пр.

Option Explicit

Public Function GroupNameIncrement(strName _
As String) As AcadGroup
  Dim objGrps As AcadGroups
  Dim objGrp As AcadGroup
  Dim strValue As String
  Dim intCnt As Integer
  Dim blnFound As Boolean
  On Error GoTo Err_Control
  Set objGrps = ThisDrawing.Groups
  Do
    intCnt = intCnt + 1
    strValue = strName & intCnt
    For Each objGrp In objGrps
      If objGrp.Name = strValue Then
        blnFound = True
        Exit For
      Else
        blnFound = False
      End If
    Next objGrp
  Loop Until Not blnFound
  Set GroupNameIncrement = objGrps.Add(strValue)
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
End Function

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