Примитивы чертежей AutoCAD
|
|||||||||
Пример создания класса для работы с примитивами AutoCAD
Сейчас мы попробуем создать класс объекта, который позволит нам задавать параметры и получать значения свойств отрезка. Создайте VBA проект, добавте в него модуль класса. Задайте этому модулю класса имя "imaLine". Добавим в класс два свойства Начальную точку (StartPoint) и Конечную точку (EndPoint). Для этого опишем две переменные в разделе General Declarations модуля класса и добавим соответствующие функции:
Ну а теперь давйте
придумаем, зачем намэто все было нужно и как это можно использовать.
Теперь, если Вы запустите процедуру NotARealLine и укажете две точки, то будет создан объект objLine как экземпляр класса imaLine, его свойствам будут присвоены указанные Вами точки, Х координаты которых будут напечатаны в окне Immediate. "Ну и что с того?" - спросите Вы. И правильно спросите. Пока ничего. Надо еще доработать наш класс. Добавим в него свойство Lenght, определяющее длину линии. Это будет свойство "Только для чтения", поэтому процедура Property Let не нужна. Чтобы создать свойство Lenght добавте в модуль класса следующий код:
Подправим наш код в модуле ThisDrawing и опять запустим процедуру NotARealLine
Теперь наш класс не только занимает место на диске в виде программного кода, но и выполняет полезную работу. Вычисляет длину между указанными точками. А представьте, ведь в этот класс можно добавить, например, метод DrawLine (Отрисовать линию). Давайте попробуем. Добавьте в модуль класса следующий код:
Снова подправим наш код в модуле ThisDrawing и опять запустим процедуру NotARealLine
Теперь мы не только получаем информацию о длине нашей линии, но и отрисовываем ее
А можно пойти и дальше, создать свойства MidPoint (Средняя точка), LineType (Тип линии, задающий собственно Тип линии, ее толщину и цвет). И это далеко не все, что можно придумать. Можно создать класс Кольцевой сектор, со всевозможными свойствами типа Радиуса, Площадь, Периметр. И, естественно, с методом DrawSector... Как Вам простор для деятельности?
|
|||||||||
Выбор объектовПроцедура сохранения всех объектов с заданного слоя в отдельном чертеже.
Работа с SelectionSet (Набор объектов)
- Добавление объектов
в набор путем указания мышью
Проверка, есть ли в заданной точке текстовый объект
Перед запуском процедуры создайте в текущем чертеже текстовый объект в точке X = -1.75, Y = 1.063, Z = 0. Функция вернет содержимое текстового объекта.
Получение набора объектов, пересекающихся с выбранной линией
Определение габаритов группы выбранных объектов
После запуска процедуры выберите несколько объектов и изображение будет масштабировано по их габаритам.
Использование фильтра для выбора объектов.
При запуске этой процедуры будут выбраны только текстовые объекты
Обеспечение фильтра выбора объектов
Перед запуском процедуры создайте в чертеже три слоя Prova1, Prova2 и Prova3. Разместите по несколько объектов на каждом из этих слоев. После запуска процедуры будут выбраны только те объекты, которые не находятся на слоях Prova1 и Prova2
Использование меток для создания набора
Отслеживание выбора пользователем примитивов
Если переменная blnOn равна True, то при выборе пользователем в чертеже примитива будет возникать диалоговое окно с информацией об объекте.
|
|||||||||
Изменение свойств объектов
Изменения цвета объектов
с помощью диалогового окна,
|
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 & "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 |
Поместите в стандартный модуль приведенный ниже код. Затем создайте в чертеже два слоя. Разместите на каждом из этих слоев по несколко примитивов 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
|
Функции, находящиеся в других разделах
Защита от изменений всех слоев вставленных в чертеж внешних ссылок