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

Примитивы чертежей 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

 

 

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