УПРАВЛЕНИЕ ОКРУЖЕНИЕМ АВТОКАД
ОТКРЫТИЕ, СОХРАНЕНИЕ И ЗАКРЫТИЕ РИСУНКА
Коллекция Documents и объект Document обеспечивают доступ к файловым функциям.
Для этого следует использовать один из методов Add, Close, Save, SaveAs, Import, Export. Пример открытия рисунка:
Пример создания рисунка
Sub OpenDrawing() Dim dwgName As String dwgName = "c:\Program Files\acad2002\sample\campus.dwg" If Dir(dwgName) <> "" Then ThisDrawing.Application.Documents.Open dwgName Else MsgBox "Файл " & dwgName & " не существует." End If End SubПример сохранения рисунка
Sub NewDrawing() Dim docObj As AcadDocument Set docObj = ThisDrawing.Application.Documents.Add End SubПроверка были ли в рисунке какие-то изменения с момента последнего сохранения
Sub SaveActiveDrawing() ' Сохранить рисунок с текущим именем ThisDrawing.Save ' А теперь с новым именем ThisDrawing.SaveAs "MyDrawing.dwg" End Sub
Sub TestIfSaved() If Not (ThisDrawing.Saved) Then If MsgBox("Сохранить изменения?", vbYesNo) = vbYes Then ThisDrawing.Save End If End SubУСТАНОВКА СОБСТВЕННЫХ ПРЕДПОЧТЕНИЙ
Доступ к объекту PreferencesПосле чего можно получить доступ к любому объекту Preference (предпочтений) пользуясь свойствами Display, Drafting, Files, OpenSave, Output, Profile, Selection, System, и User properties. Например сменить размер перекрестия
Dim acadPref as AcadPreferences Set acadPref = ThisDrawing.Application.Preferences
acadPref.Display.CursorSize = 100DATABASE PREFERENCES
Данный объект включает все настройки которые сохраняются всместе с текущим рисунком.УПРАВЛЕНИЕ ОКНОМ ПРИЛОЖЕНИЯ
Пример смены размера и положения окна, минимизация и увеличение до максимумаПроверка состояния окна
Sub PositionApplicationWindow() ThisDrawing.Application.WindowTop = 0 ThisDrawing.Application.WindowLeft = 0 ThisDrawing.Application.width = 400 ThisDrawing.Application.height = 400 ThisDrawing.Application.WindowState = acMax ThisDrawing.Application.WindowState = acMin End SubСделать окно невидимым
Sub CurrentWindowState() Dim CurrWindowState As Integer Dim msg As String CurrWindowState = ThisDrawing.Application.WindowState msg = Choose(CurrWindowState, "normal", "minimized", "maximized") MsgBox "Окно приложения" + msg End Sub
ThisDrawing.Application.Visible = FalseУПРАВЛЕНИЕ ОКНОМ РИСУНКА
Аналогично окну приложения можно менять размеры и подчиненного окна - рисунка, как например:
Sub CurrentWindowState() Dim CurrWindowState As Integer Dim msg As String ThisDrawing.Width = 400 ThisDrawing.Height = 400 ThisDrawing.WindowState = acMin ThisDrawing.WindowState = acMax CurrWindowState = ThisDrawing.WindowState msg = Choose(CurrWindowState, "normal", "minimized", "maximized") MsgBox "Окно документа " + msg End SubИСПОЛЬЗОВАНИЕ ZOOM.
Виды это особые комбинации расположения, масштаба и ориентации рисунка. Команда zoom не меняет размер рисунка, она влияет только на размер его отображения на экране. Автокад предлагает несколько путей "зуммирования" по указанному окну, вписать рисунок в окно, указать масштаб вручную. Для "зуммирования" с указанием границ используются методыZoomWindow
илиZoomPickWindow
Первый из них позволяет все сделать чисто программно, второй требует ввода границ окна от пользователя. Пример:
Sub ZoomWindow() MsgBox "Увеличение в пределах:" & vbCrLf & "1.3, 7.8, 0" & vbCrLf & "13.7, -2.6, 0" Dim point1(0 To 2) As Double Dim point2(0 To 2) As Double point1(0) = 1.3: point1(1) = 7.8: point1(2) = 0 point2(0) = 13.7: point2(1) = -2.6: point2(2) = 0 ThisDrawing.Application.ZoomWindow point1, point2 MsgBox "А теперь ZoomPickWindow" ThisDrawing.Application.ZoomPickWindow End SubМАСШТАБИРОВАНИЕ ВИДА
Если нужно точно указать коэффициент увеличения или уменьшения есть три способа:При этом следует просто ввести значение. Например 2 для увеличения в 2 раза и .5 для уменьшения в два раза.
- Относительно границ рисунка
- Относительно текущего вида
- Относительно единиц вычерчивания на листе
Для масштабирования вида используется метод
ZoomScaled
, на входе он принимает два параметра масштаб и тип масштаба. Типы масштаба задаются конст. acZoomScaledAbsolute, acZoomScaledRelative, acZoomScaledRelativePSpace
Sub ZoomScaled() MsgBox "Масштабирование:" & vbCrLf & "Тип: acZoomScaledRelative" & vbCrLf & "Фактор: 2" Dim scalefactor As Double Dim scaletype As Integer scalefactor = 2 scaletype = acZoomScaledRelative ThisDrawing.Application.ZoomScaled scalefactor, scaletype End SubЦЕНТРИРОВАНИЕ
Указанную точку рисунка можно поместить по центру экрана методомZoomCenter
как в следующем примере:
Sub ZoomCenter() MsgBox "Центрировать:" & vbCrLf & "Центр: 3,3,0" & vbCrLf & "Увеличение: 10" Dim Center(0 To 2) As Double Dim magnification As Double Center(0) = 3: Center(1) = 3: Center(2) = 0: magnification = 10 ThisDrawing.Application.ZoomCenter Center, magnification End SubПОКАЗ ГРАНИЦ (LIMITS) И ПРОТЯЖЕННОСТИ (EXTENTS) РИСУНКА
Для отображения границ рисунка или границ объектов используется методыZoomAll, ZoomExtents, ZoomPrevious
. Первый из них показывает рисунок полностью. Если границы объектов выходят за пределы границ рисунка, то показывается по границам объектов и наооборот.
ZoomExtents
позволяет указать в активном видовом экране границы рисунка в котором отображаются все ранее построенные объекты текущей вкладки рисунка, находящиеся на включенных и размороженных слоях.
ZoomAll
аналогичноZoomExtents
но при этом включается еще и зона границ. Если зона границ окажется заполнена мало все окно может оказаться пустым. Наиболее удобный вариант просмотра всего рисунка - первый
Sub ZoomAll() MsgBox "ZoomAll" ThisDrawing.Application.ZoomAll MsgBox "ZoomExtents" ThisDrawing.Application.ZoomExtents End SubИСПОЛЬЗОВАНИЕ ИМЕНОВАННЫХ ВИДОВ
Виды можно именовать, для того чтобы использовать их в дальнейшем, в имени могут использоваться до 255 символов, ключая цифры и спецсимволы.Видовой экран можно разбивать на части методами: acViewport2Horizontal, acViewport2Vertical, acViewport3Left, acViewport3Right, acViewport3Horizontal, acViewport3Vertical, acViewport3Above, acViewport3Below, acViewport4.
Sub AddView() Dim viewObj As AcadView Set viewObj = ThisDrawing.Views.Add("View1") msgbox "А теперь удалить вид" ThisDrawing.Views("View1").Delete End SubПример разбивки видовых экранов и перебор открытых окон
Sub SplitAViewport() Dim vportObj As AcadViewport Set vportObj = ThisDrawing.Viewports.Add("TEST_VIEWPORT") vportObj.Split acViewport2Horizontal ThisDrawing.ActiveViewport = vportObj End SubОбновление содержимого экрана нужно потому что не все методы сразу это делают
Sub IteratingViewportWindows() Dim vportObj As AcadViewport Set vportObj = ThisDrawing.Viewports.Add("TEST_VIEWPORT") ThisDrawing.ActiveViewport = vportObj ' сделать активным vportObj.Split acViewport4 ' Разбить на 4 окна ' Перебор видовых экранов, подсвечивая каждый ' и показывая углы для каждого Dim vport As AcadViewport Dim LLCorner As Variant,URCorner As Variant For Each vport In ThisDrawing.Viewports ThisDrawing.ActiveViewport = vport LLCorner = vport.LowerLeftCorner URCorner = vport.UpperRightCorner MsgBox "Видовой экран: " & vport.Name & " активнен." & _ vbCrLf & "Нижний левый угол: " & _ LLCorner(0) & ", " & LLCorner(1) & _ vbCrLf & "Верхний правый: " & URCorner(0) & ", " & URCorner(1) Next vport End Sub
Sub UpdateDisplay() Dim circleObj As AcadCircle Dim center(0 To 2) As Double Dim radius As Double center(0) = 1: center(1) = 1: center(2) = 0: radius = 1 Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius) circleObj.Color = acRed circleObj.Update End SubПЕРЕУСТАНОВКА АКТИВНЫХ ОБЪЕКТОВ
Изменение большинства активных объектов (слоев, типов линий) вступает в силу немедленно, однако некоторые активные объекты требуют повторной установки. (это стили текста, видовые экраны и ПСК). Для их переустановки требуется установка свойств ActiveTextStyle, ActiveUCS, ActiveViewport.
Sub ResetActiveViewport() ' переключим сетку ThisDrawing.ActiveViewport.GridOn = Not (ThisDrawing.ActiveViewport.GridOn) ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport End SubУСТАНОВКА И СЧИТЫВАНИЕ СИСТЕМНЫХ ПЕРЕМЕННЫХ
У объектаDocument
есть два метода на этот случайSetVariable и GetVariable. Пример ThisDrawing.SetVariable "TEXTFILL", 1
ВЫСОКОТОЧНОЕ ВЫЧЕРЧИВАНИЕ
Автокад позволяет вычерчивать объекты с точно заданными характеристиками, не прибегая при этом к утомительным вычислениям. Ограничем VBA для Autocad 2000 является то что через VBA нельзя установить изометрическую сетку и привязку, установить объектную привязку, указать измеряемые отрезки на объекте или поделить объект на сегменты.
РЕГУЛИРОВКА ПРИВЯЗКИ И ВЫРАВНИВАНИЯ СЕТКИ
Изменение угла и базовой точки. В данном примере базовая точка устанавливается равной 1,1 и угол наклона сетки 30 градусов.Включение режима ОРТО (нужен для простой отрисовки перпендикуляров)
Sub ChangeSnapBasePoint() ' Включим сетку ThisDrawing.ActiveViewport.GridOn = True ' Сменим базовую точку 1,1 Dim newBasePoint(0 To 1) As Double newBasePoint(0) = 1: newBasePoint(1) = 1 ThisDrawing.ActiveViewport.SnapBasePoint = newBasePoint ' Сменим угол для привязки на 30 градусов (.575 радиан) Dim rotationAngle As Double rotationAngle = 0.575 ThisDrawing.ActiveViewport.SnapRotationAngle = rotationAngle ' переустановим видовой экран ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport End Sub
ThisDrawing.ActiveViewport.OrthoOn = True
Построение конструкционных линий (это те которые в обе стороны бесконечны)
Опрос конструкционных линий. В примере ищется базовая точка и направляющий вектор
Sub AddXLine() Dim xlineObj As AcadXline Dim basePoint(0 To 2) As Double Dim directionVec(0 To 2) As Double basePoint(0) = 2#: basePoint(1) = 2#: basePoint(2) = 0# directionVec(0) = 1#: directionVec(1) = 1#: directionVec(2) = 0# Set xlineObj = ThisDrawing.ModelSpace.AddXLine (basePoint, directionVec) ThisDrawing.Application.ZoomAll End Sub
Dim BPoint As Variant Dim Vector As Variant Set BPoint = xlineObj.basePoint Set Vector = xlineObj.DirectionVectorСОЗДАНИЕ, ОПРОС И РЕДАКТИРОВАНИЕ ЛУЧЕЙ
Sub EditRay() Dim rayObj As AcadRay Dim basePoint(0 To 2) As Double,secondPoint(0 To 2) As Double ' Определим луч basePoint(0) = 3#: basePoint(1) = 3#: basePoint(2) = 0# secondPoint(0) = 4#: secondPoint(1) = 4#: secondPoint(2) = 0# ' Создадим луч в пространстве модели Set rayObj = ThisDrawing.ModelSpace.AddRay (basePoint, secondPoint) ThisDrawing.Application.ZoomAll ' Получим состояние луча MsgBox "Базовая точка луча: " & rayObj.basePoint(0) & ", " & _ rayObj.basePoint(1) & ", " & rayObj.basePoint(2) & vbCrLf & _ "Направляющий вектор луча: " & rayObj.DirectionVector(0) & ", " & _ rayObj.DirectionVector(1) & ", " & rayObj.DirectionVector(2) ' Изменим направляющий вектор луча Dim newVector(0 To 2) As Double newVector(0) = -1 : newVector(1) = 1 : newVector(2) = 0 rayObj.DirectionVector = newVector ThisDrawing.Regen False MsgBox "Базовая точка луча: " & rayObj.basePoint(0) & ", " & _ rayObj.basePoint(1) & ", " & rayObj.basePoint(2) & vbCrLf & _ "Направляющий вектор луча: " & rayObj.DirectionVector(0) & ", " & _ rayObj.DirectionVector(1) & ", " & rayObj.DirectionVector(2) End SubВЫЧИСЛЕНИЯ С ИСПОЛЬЗОВАНИЕМ ВЫРАЖЕНИЙ
используя методы объекта Utitlity можно быстро решать математические задачки или найти нужную точку на рисунке. Кроме того возможно:
- Найти угол линии от оси X методом AngleFromXAxis
- Преобразовать угол из строки в вещественное (двойной точности) методом AngleToReal
- Преобразовать угол из вещественного (двойной точности) в строку методом AngleToString
- Преобразовать расстояние из строки в вещественное (двойной точности) методом DistanceToReal
- Создать переменную типа Variant, содержащую массив целых, с плавающей точкой двойной точности и т.д. методом CreateTypedArray
- Найти точку отложенную на заданном расстоянии и под заданным углом методом PolarPoint
- Перевести точку в другую систему координат методом TranslateCoordinates
- Найти расстояние между двумя точками методом GetDistance
Sub GetDistanceBetweenTwoPoints() Dim returnDist As Double returnDist = ThisDrawing.Utility.GetDistance (, "Выбери 2 точки.") MsgBox "Расстояние между точками: " & returnDist End SubПОДСЧЕТ ПЛОЩАДЕЙ
Можно выполнить используя значение свойстваArea
, пример.
Sub CalculateDefinedArea() Dim p1 As Variant,p2 As Variant,p3 As Variant,p4 As Variant,p5 As Variant ' Получить точки от пользователя p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "1-ая точка: ") p2 = ThisDrawing.Utility.GetPoint(p1, vbCrLf & "2-ая точка: ") p3 = ThisDrawing.Utility.GetPoint(p2, vbCrLf & "3-ая точка: ") p4 = ThisDrawing.Utility.GetPoint(p3, vbCrLf & "4-ая точка: ") p5 = ThisDrawing.Utility.GetPoint(p4, vbCrLf & "5-ая точка: ") ' Создаем двумерную полилинию Dim polyObj As AcadLWPolyline Dim vertices(0 To 9) As Double vertices(0) = p1(0): vertices(1) = p1(1) vertices(2) = p2(0): vertices(3) = p2(1) vertices(4) = p3(0): vertices(5) = p3(1) vertices(6) = p4(0): vertices(7) = p4(1) vertices(8) = p5(0): vertices(9) = p5(1) Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline (vertices) polyObj.Closed = True ThisDrawing.Application.ZoomAll MsgBox "Площадь определенная точками " & polyObj.Area End SubПОЛУЧЕНИЕ ВВОДА ОТ ПОЛЬЗОВАТЕЛЯ
Объект Utility может получать ввод от пользователя данных определенного типа, например методGetString
возвращает строку,GetPoint
возвращает значение типа Variant иGetInteger
возвращает целое. Управление вводом пользователя можно осуществлять методомInitializeUserInput
. Он позволяет проверять пустой ввод (NULL), ввод отрицательных значений. МетодGetString
принимает два параметра, если первый из них равен 0, то пробел сразу завершает ввод, второй - строка подсказка.Метод
Sub GetStringFromUser() Dim retVal As String retVal = ThisDrawing.Utility.GetString (1, vbCrLf & "Как вас зовут: ") MsgBox "Привет, " & retVal End SubGetPoint
тоже принимает два параметра, необязательную первую точку и строку подсказки. Для ограничения выбора пользователя при вводе может использовать вызов методаInitializeUserInput
.Метод
Sub GetPointsFromUser() Dim startPnt As Variant,endPnt As Variant Dim prompt1 As String,prompt2 As String prompt1 = vbCrLf & "Начальная точка линии: " prompt2 = vbCrLf & "Конечная точка линии: " startPnt = ThisDrawing.Utility.GetPoint(, prompt1) ' Используем ранее введенную точку как базовую endPnt = ThisDrawing.Utility.GetPoint(startPnt, prompt2) ThisDrawing.ModelSpace.AddLine startPnt, endPnt ThisDrawing.Application.ZoomAll End SubGetKeyword
принимает только один параметр, это ключевое слово Autocad и так же может использовать вызова методаInitializeUserInput
.
Более дружественный для пользователя вариант выбирает один из вариантов как выбор по умолчанию, осуществляющийся при нажатии Enter
Sub KeyWord() Dim keyWord As String ThisDrawing.Utility.InitializeUserInput 1, "Line Circle Arc" keyWord = ThisDrawing.Utility.GetKeyword (vbCrLf & "Введите (Line/Circle/Arc): ") MsgBox keyWord End Sub
Sub KeyWord2() Dim keyWord As String ThisDrawing.Utility.InitializeUserInput 0, "Line Circle Arc" keyWord = ThisDrawing.Utility.GetKeyword (vbCrLf & "Введите (Line/Circle/): ") If keyWord = "" Then keyWord = "Arc" MsgBox keyWord End Sub УПРАВЛЕНИЕ ВВОДОМ ПОЛЬЗОВАТЕЛЯ
Применение методаInitializeUserInput
позволяет определить ключевые слова или ограничить тип вводимых значений. Данный метод может применяться совместно со следующими методами GetAngle, GetCorner, GetDistance, GetInteger, GetKeyword, GetOrientation, GetPoint, GetReal (но не с GetString, в этом случае есть метод GetInput для получения строкового значения).Метод
InitializeUserInput
принимает два параметра - первый битовое значение, определяющее опции ввода, второй строковый - определяет допустимые ключевые слова.ПОЛУЧЕНИЕ ЦЕЛОГО ИЛИ КЛЮЧЕВОГО СЛОВА ПУТЕМ ВВОДА В КОМАНДНОЙ СТРОКЕ
Пример ввода положительного целого
Sub UserInput() ' Первый параметр (6) ограничивает ввод положительными целыми ' Второй список ключевых слов ThisDrawing.Utility.InitializeUserInput 6, "Big Small Regular" Dim promptStr As String promptStr = vbCrLf & "Размер (Big/Small/[Regular]):" ' Ввод ключевого слов в метод GetInteger вызовет ошибку ' чтобы позволить программе выполняться дальше ' установим обработчик ошибок On Error Resume Next ' Получить ввод от пользователя Dim returnInteger As Integer returnInteger = ThisDrawing.Utility.GetInteger(promptStr) ' Проверить нет ли ошибки, затем использовать GetInput для получения ' строки иначе значение returnInteger. If Err.Description = "User input is a keyword" Then Dim returnString As String returnString = ThisDrawing.Utility.GetInput() Err.Clear Else If returnInteger = 0 Then ' Нажат ENTER returnString = "Regular" ' значение по-умолчанию Else returnString = returnInteger ' введенное значение End If End If MsgBox returnString, , "Пример InitializeUserInput" End SubДОСТУП К КОМАНДНОЙ СТРОКЕ AUTOCAD
Имитировать ввод команд в командную строку с возможностью передачи параметров команде позволяет методSendCommand
. Пробел в данной строке эквивалентен нажатию Enter. Вызов данного метода без аргументов не допускается.Следующий пример создает окружность с центром (2,2,0) и радиусом 4.
Обратите внимание на пробел в конце каждой строки.
Sub SendACommandToAutoCAD() ThisDrawing.SendCommand "_Circle 2,2,0 4 " ThisDrawing.SendCommand "_zoom a " End SubЕСЛИ НЕ ОТКРЫТ НИ ОДИН ДОКУМЕНТ
Несмотря на то, что Autocad всегда стартует с пустым или открытым документом существует возможность закрыть все документы, при этом главное меню сократится до 4-х пунктов (File, View, Window, Help), а так же пропадет командная строка. Интерфейс ActiveX в данном случае позволяет выполнять только следующие действияЭти действия доступны для всей коллекции
- Открыть документ
- Создать документ
- Импортировать документ
- Выйти из Autocad
Documents
, кроме того методы и свойства данной коллекции ограничены набором методов и свойств объектаApplication. Свойство Count
коллекцииDocuments
открыт ли хоть один документ.If Documents.Count > 0 Then
открыт как минимум один документ. Здесь важно так же заметить, что объектThisDrawing
неопределен, если ни открыт ни один документ, поэтому попытка выполнить макрос сThisDrawing
приведет к ошибке периода выполнения. Вместо этого используй функциюGetObject
ИМПОРТ ФАЙЛОВ ДРУГИХ ФОРМАТОВ
МетодImport
позволяет импортировать файлы форматов DXF, SAT, BMP, PostScript. Он принимает три параметра: имя файла, точку вставки и фактор масштабирования.ЭКСПОРТ В ДРУГИЕ ФОРМАТЫ
МетодExport
поддерживает следующие форматы: WMF, SAT, EPS, DXF, DWF, BMP. Он принимает три параметра: имя создаваемого файла, тип создаваемого файла и набор экспортируемых объектов. При экспорте в WMF, SAT или BMP должен существовать непустой набор. В EPS и DXF экспортируется весь рисунок.Пример эскпорта-импорта в DXF
Sub ImportingAndExporting() ' Созадим окружность, чтоб было что экспортировать Dim circleObj As AcadCircle Dim centerPt(0 To 2) As Double,radius As Double centerPt(0) = 2: centerPt(1) = 2: centerPt(2) = 0: radius = 1 Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPt, radius) ThisDrawing.Application.ZoomExtents ' Создадим пустой набор Dim sset As AcadSelectionSet Set sset = ThisDrawing.SelectionSets.Add("NEWSSET") ' Экспорт в файл C:\DXFExprt, если каталог не существует - ошибка Dim exportFile As String exportFile = "C:\DXFExprt" ThisDrawing.Export exportFile, "DXF", sset ' Определим импорт Dim importFile As String Dim insertPoint(0 To 2) As Double Dim scalefactor As Double importFile = "C:\DXFExprt.dxf" insertPoint(0) = 0: insertPoint(1) = 0: insertPoint(2) = 0: scalefactor = 2# ' Импортируем файл ThisDrawing.Import importFile, insertPoint, scalefactor ThisDrawing.Application.ZoomExtents End Sub
Читать дальше - В начало - На главную