НОУ ИНТУИТ | Программирование в AutoCAD. Лекция 8: Программирование на VBA

Опубликован: 21.02.2012 | Доступ: свободный | Студентов: 2061 / 499 | Оценка: 4.20 / 4.40 | Длительность: 19:35:00

Масштабирование вида

Если нужно точно указать коэффициент увеличения или уменьшения изображения на экране, то можно воспользоваться тремя способами:

Относительно границ рисунка
Относительно текущего вида
Относительно единиц вычерчивания на листе

При этом следует просто ввести значение. Например, 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 но при этом включается еще и зона границ. Если зона границ окажется заполнена мало все окно может оказаться пустым. Наиболее удобным вариантом просмотра всего рисунка является метод 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

Высокоточное вычерчивание

AutoCAD позволяет вычерчивать объекты с точно заданными характеристиками, не прибегая при этом к утомительным вычислениям. Ограничением VBA для Autocad является то что через 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 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

Программирование на VBA