УПРАВЛЕНИЕ ОКРУЖЕНИЕМ АВТОКАД

ОТКРЫТИЕ, СОХРАНЕНИЕ И ЗАКРЫТИЕ РИСУНКА

Коллекция 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
Dim acadPref as AcadPreferences
Set acadPref = ThisDrawing.Application.Preferences
После чего можно получить доступ к любому объекту Preference (предпочтений) пользуясь свойствами Display, Drafting, Files, OpenSave, Output, Profile, Selection, System, и User properties. Например сменить размер перекрестия
acadPref.Display.CursorSize = 100

DATABASE 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 символов, ключая цифры и спецсимволы.
Sub AddView()
  Dim viewObj As AcadView
  Set viewObj = ThisDrawing.Views.Add("View1")
  msgbox "А теперь удалить вид"
  ThisDrawing.Views("View1").Delete
End Sub
Видовой экран можно разбивать на части методами: acViewport2Horizontal, acViewport2Vertical, acViewport3Left, acViewport3Right, acViewport3Horizontal, acViewport3Vertical, acViewport3Above, acViewport3Below, acViewport4.
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 можно быстро решать математические задачки или найти нужную точку на рисунке. Кроме того возможно:
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 Sub
Метод GetPoint тоже принимает два параметра, необязательную первую точку и строку подсказки. Для ограничения выбора пользователя при вводе может использовать вызов метода 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 Sub
Метод GetKeyword принимает только один параметр, это ключевое слово Autocad и так же может использовать вызова метода InitializeUserInput.

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
Более дружественный для пользователя вариант выбирает один из вариантов как выбор по умолчанию, осуществляющийся при нажатии Enter
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 в данном случае позволяет выполнять только следующие действия Эти действия доступны для всей коллекции 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
Читать дальше - В начало - На главную