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

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

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

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

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

Создание и редактирование примитивов и наборов объектов

Создание различных объектов возможно как в пространстве листа, так и в пространстве модели, кроме того объекты могут входить в состав блоков. Обычно для создания объекта используется метод Add. После того как объект создан можно изменять его свойства слой, цвет, тип линий и т.д.

Создание объектов

Несмотря, на то что Autocad> может создать один и тот же объект разными путями, ActiveX автоматизация допускает только один метод на объект. Например, для создания окружности можно указать 1. центр и радиус 2. две точки, задающие диаметр, 3. три точки определяющие окружность, 4. два тангенса и радиус. Однако ActiveX позволят воспользоваться только первым из них.

Примечание: метод VB и VBA CreateObject или Dim позволяют создать только объект Autocad Application, все остальные объекты создаются методами Add и Add[Object] .

Определение объекта-контейнера

Объекты создаются в коллекциях ModelSpace, PaperSpace или объекте Block. На объект можно сослаться непосредственно или через объектную переменную. Непосредственная ссылка включает всю иерархию:

Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint,endPoint)

Для ссылки на объект через объектную переменную следует создать переменную типа AcadModelSpace или AcadPaperSpace. И установить ссылку на нужное свойство активного документа. В следующем примере две объектные переменные ссылаются на Model Space и PaperSpace соответственно:

Dim moSpace As AcadModelSpace
Dim paSpace As AcadPaperSpace
Set moSpace = ThisDrawing.ModelSpace
Set paSpace = ThisDrawing.PaperSpace

В следующей строке в пространство модели добавляется линия через объектную переменную:

Set lineObj = moSpace.AddLine(startPoint,endPoint)

Создание линий

Возможно создание различных типов линий - проcто линия, мультилиния, мультилиния с дуговыми сегментами. Обычно для обрисовки линий задаются координаты вершин. Тип линии по умолчанию непрерывный. Методы для создания линий:

Стандартные линии и мультилини создаются в плоскости XY полилинии создаются в Object Coordinat System. Пример создания полилини:

Sub AddLightWeightPolyline()
  Dim plineObj As AcadLWPolyline
  Dim points(0 To 5) As Double
  ' Вершины двумерной полилини
  points(0) = 2: points(1) = 4
  points(2) = 4: points(3) = 2
  points(4) = 6: points(5) = 4
  ' Создаем полилинию в пространстве модели
  Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
  ThisDrawing.Application.ZoomExtents
End Sub

Создание криволинейных объектов

Все подобные объекты (эллипсы, сплайны, дуги, окружности) строятся в плоскости XY мировой системы координат. Для их создания используется один из следующих методов:

Пример создания сплайна

Sub CreateSpline()
  Dim splineObj As AcadSpline
  Dim noOfPoints As Integer
  Dim startTan(0 To 2) As Double
  Dim endTan(0 To 2) As Double
  Dim fitPoints(0 To 8) As Double
  ' Определение переменных
  noOfPoints = 3
  startTan(0) = 0.5: startTan(1) = 0.5: startTan(2) = 0
  endTan(0) = 0.5: endTan(1) = 0.5: endTan(2) = 0
  fitPoints(0) = 1: fitPoints(1) = 1: fitPoints(2) = 0
  fitPoints(3) = 5: fitPoints(4) = 5: fitPoints(5) = 0
  fitPoints(6) = 10: fitPoints(7) = 0: fitPoints(8) = 0
  ' Собственно сплайн
  Set splineObj = ThisDrawing.ModelSpace.AddSpline (fitPoints, startTan, endTan)
  ZoomExtents
End Sub

Более подробная информация о сплайнах в AutoCAD ActiveX and VBA Reference.

Создание точки

Стиль создаваемой точки и ее размер можно указать в относительных единицах к размеру экрана или в абсолютных. Управление видом точек делается через системные переменные PDMODE, PDSIZE. Значения переменной PDMODE равные 0,2,3,4 представляют разные формы точки, значение равное 1 - означает невидимую точку. Добавление 32, 64 или 96 означает вокруг точки фигуру (окружность, квадрат, окружность вписанную в квадрат). Значение переменной PDSIZE равное нулю задает размер точки 5% от размера экрана, а любые положительные значения - абсолютный размер. Отрицательные же значения интерпретируются как процент от размера видового экрана. Размер всех точек пересчитывается при регенерации, т.е. изменение PDMODE, PDSIZE сразу не заметно. Для установки значений системных переменных используется метод SetVariable, ниже приведен пример его применения:

Sub CreatePoint()
  Dim pointObj As AcadPoint
  Dim location(0 To 2) As Double
  ' Определение положения точки
  location(0) = 5#: location(1) = 5#: location(2) = 0#
  ' Ставим точку
  Set pointObj = ThisDrawing.ModelSpace.AddPoint(location)
  ThisDrawing.SetVariable "PDMODE", 34
  ThisDrawing.SetVariable "PDSIZE", 1
  ZoomExtents
End Sub

Создание сплошной заливки

Возможно создание треугольной и прямоугольной области со сплошной заливкой. Наиболее быстрый способ - создание области при выключенной системной переменной FILLMODE и затем включение ее. Последовательность второй и четвертой точки области определяют способ заливки (слева направо и сверху вниз - если 1,2,3,4 то прямоугольная, если 1,2,4,3 то треугольная). Первые две точки задают сторону полигона. Для создания области со сплошной заливкой есть метод AddSolid. Пример объекта с заливкой.

Sub CreateSolid()
  Dim solidObj As AcadSolid
  Dim point1(0 To 2) As Double,point2(0 To 2) As Double
  Dim point3(0 To 2) As Double,point4(0 To 2) As Double
  ' Определение сплошной заливки
  point1(0) = 0#: point1(1) = 0#: point1(2) = 0#
  point2(0) = 5#: point2(1) = 0#: point2(2) = 0#
  point3(0) = 5#: point3(1) = 8#: point3(2) = 0#
  point4(0) = 0#: point4(1) = 8#: point4(2) = 0#
  Set solidObj = ThisDrawing.ModelSpace.AddSolid (point1, point2, point3, point4)
  ZoomExtents
End Sub

Создание регионов

Регион представляет двухмерную замкнутую фигуру, границы которой не имеют внутренних пересечений. Может состоять из комбинации линий, окружностей, дуг, эллипсов, эллиптических дуг, сплайнов и некоторых других объектов. Весь объект должен лежать в одной плоскости. Трехмерная полилиния может быть преобразована в регион путем "взрыва". К региону применима штриховка и тень, у него есть свойства - площадь и момент инерции. Создав фигуры можно выбрав их создать регион, используя метод AddRegion. AutoCAD преобразует замкнутые двумерные и трехмерные планарные полилинии в отдельные регионы, а полилинии, линии и кривые образуют замкнутые планарные петли. Если более двух кривых разделяют конечную точку результирующий регион может быть присужден. (arbitrary) используйте Variant для хранения вновь создаваемых массивов регионов. Для подсчета количества созданных объектов Region используйте UBound(objRegions) - LBound(objRegions) + 1, где objRegions переменная Variant содержащая массив возвращенный методом AddRegion. Пример простого региона из одной окружности:

Sub CreateRegion()
  ' Определим массив хранящий границы региона
  Dim curves(0 To 0) As AcadCircle
  ' Создаем окружность как границу региона
  Dim center(0 To 2) As Double,radius As Double
  center(0) = 2: center(1) = 2: center(2) = 0: radius = 5#
  Set curves(0) = ThisDrawing.ModelSpace.AddCircle (center, radius)
  ' Теперь сам регион
  Dim regionObj As Variant
  regionObj = ThisDrawing.ModelSpace.AddRegion(curves)
  ZoomExtents
End Sub

Создание составных регионов

Путем вычитания, комбинирования и нахождения пересечений регионов или 3-мерных заливок можно создать составной регион, для чего применяется метод Boolean. При вычитании регионов этот метод применяется к первому из них. Пример:

Sub CreateCompositeRegions()
  ' Создадим две окружности - одна комната, вторая ковер в ней
  Dim RoomObjects(0 To 1) As AcadCircle
  Dim center(0 To 2) As Double
  Dim radius As Double
  center(0) = 4: center(1) = 4: center(2) = 0: radius = 2#
  Set RoomObjects(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
  radius = 1#
  Set RoomObjects(1) = ThisDrawing.ModelSpace.AddCircle(center, radius)
  ' Теперь регион из двух окружностей
  Dim regions As Variant
  regions = ThisDrawing.ModelSpace.AddRegion(RoomObjects)
  ' Скопируем его в переменную для простоты использования
  Dim RoundRoomObj As AcadRegion,PillarObj As AcadRegion
  If regions(0).Area > regions(1).Area Then
    ' Первый регион - комната
    Set RoundRoomObj = regions(0)
    Set PillarObj = regions(1)
  Else
    ' Первый регион - ковер
    Set PillarObj = regions(0)
    Set RoundRoomObj = regions(1)
  End If
  ' Окрасим комнату и ковер разными цветами
  RoundRoomObj.Color = acRed
  PillarObj.Color = acCyan
  ZoomExtents
  ' Отнимем площадь ковра от площади комнаты
  RoundRoomObj.Boolean acSubtraction, PillarObj
  MsgBox "Площадь ковра: "  RoundRoomObj.Area
End Sub

Для объединения регионов вызывайте метод Boolean и вводите константу acUnion, для операции вместо acSubtraction, а для пересечения acIntersection.

Создание штриховок

Штриховки заполняют указанную область рисунка образцом. При ее создании сначала следует создать объект Hatch методом AddHatch. Ассоциированная штриховка привязана к определенным границам и меняется вместе с ними. Привязка может быть задана только при создании штриховки, после этого штриховку можно отвязать, но нельзя привязать снова. Чтобы сделать штриховку ассоциированной следует использовать параметр Associativity=TRUE для метода AddHatch, а для разрыва связи Associativity=FALSE.

Назначение имени и типа штриховке

В AutoCAD есть сплошная заливка и более 15 штриховок применяемых в производстве. Штриховка подчеркивает отельную часть рисунка или области. Поддерживаются внешние библиотеки с образцами штриховок. Для указания уникального образца следует давать полное имя и тип штриховки. Тип штриховки указывает местоположение образцов штриховки. acHatchPatternTypePredefined (в acad.pat), acHatchPatternTypeUserDefined (используя текущий тип линий), acHatchPatternTypeCustomDefined (из другого pat-файла).

Задание границ штриховки

Как только создан объект Hatch можно добавлять границы штриховки. Они могут задаваться комбинацией линий, дуг, окружностей, двумерных полилиний, эллипсов, сплайнов и регионов. Первая граница должна быть внешней границей штриховки, (метод AppendOuterLoop). Внутренние границы задаются методом AppendInnerLoop. Они определяют незаштрихованные "островки" внутри штрихованной области. Пример штриховки.

Sub CreateHatch()
  Dim hatchObj As AcadHatch
  Dim patternName As String
  Dim PatternType As Long
  Dim bAssociativity As Boolean
  ' Определение штриховки
  patternName = "ANSI31"
  PatternType = 0
  bAssociativity = True
  ' Создать связанный объект штриховку
  Set hatchObj = ThisDrawing.ModelSpace.AddHatch (PatternType, patternName, bAssociativity)
  ' Внешняя граница - окружность
  Dim outerLoop(0 To 0) As AcadEntity
  Dim center(0 To 2) As Double
  Dim radius As Double
  center(0) = 3: center(1) = 3: center(2) = 0: radius = 1
  Set outerLoop(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
  hatchObj.AppendOuterLoop (outerLoop)
  hatchObj.Evaluate
  ThisDrawing.Regen True
End Sub

Редактирование объектов

Для изменения существующего объекта применяют методы и свойства соответствующих объектов, для видимых объектов нужно еще применять метод Update.

Работа с именованными объектами и их переименование

Именованные объекты это блоки, слои, группы, размерные стили и т.п. Чистка именованных объектов на которые в текущем рисунке нет ссылок осуществляется методом ThisDrawing.PurgeAll.

По мере усложнения чертежа может возникать необходимость давать объектам другие более осмысленные имена. Переименовать можно почти все, кроме, например, 0 слоя и типа линий continuose. Имя может быть длиной до 255 символов (буквы, цифры, спецсимволы кроме тех которые используются самим AutoCADом < > / \ " : ; ? * | = ' и запятая). Пример переименования

Sub RenamingLayer()
  Dim layerObj As AcadLayer
  Set layerObj = ThisDrawing.Layers.Add("NewLayer")
  layerObj.Name = "MyLayer"
End Sub

Выбор объектов

Набор представляет собой группу объектов AutoCAD указанных для обработки как одно целое. Набор может состоять из объектов разных слоев, разных цветов и т.п. Создание набора двухступенчатый процесс. Сначала создается набор и включается в коллекцию SelectionSets. Затем идет работа с объектами, входящими в набор. Для создания именованного набора используем метод Add.

Sub CreateSelectionSet()
  Dim selectionSet1 As AcadSelectionSet
  ' Создание набора
  Set selectionSet1 = ThisDrawing.SelectionSets.Add("NewSelectionSet")
End Sub

Добавление объектов в набор

Добавление объектов в набор может осуществляется одним из следующих методов:

Sub AddToASelectionSet()
  Dim sset As AcadSelectionSet
  Set sset = ThisDrawing.SelectionSets.Add("SS1")
  ' Запрос объектов от пользователя, Enter - конец ввода
  sset.SelectOnScreen
  ' Пройтись по набору и перекрасить его в синий
  Dim entry As AcadEntity
  For Each entry In sset
    entry.Color = acBlue
    entry.Update
  Next entry
End Sub

Фильтрация набора

Фильтрация набора объектов (например по цвету, типу объекта) осуществляется через список фильтров. При этом фильтрация по цвету различает только цвета явно назначенные объектам, но не унаследованные от слоя (!). Для применения механизма фильтрации используется тип фильтра и данные фильтра, которые сортируются. AutoCAD ActiveX автоматизация использует DXF-коды групп для указания типа фильтров. Наиболее часто используемые фильтры перечислены ниже.

Примеры различных фильтров

FilterType = 0
FilterData = "TEXT"
sset.SelectOnScreen FilterType, FilterData
' Только линии
FilterType = 0
FilterData = "LINE"
sset.SelectOnScreen FilterType, FilterData
' Только со слоя FLOOR9
FilterType = 8
FilterData = "FLOOR9"
sset.SelectOnScreen FilterType, FilterData
' Только синие (5)
FilterType = 62
FilterData = 5
sset.SelectOnScreen FilterType, FilterData

Удаление объектов из набора

При выборе всех объектов в набор может быть необходимость исключить объекты, это делается следующими методами:

Пример:

Sub AddToASelectionSet()
  Dim sset As AcadSelectionSet
  On Error GoTo ErrHandle

  ' создали произвольный набор, он пока пустой
  Set sset = ThisDrawing.SelectionSets.Add("SS1")
  ' Запрос объектов от пользователя, Enter - конец ввода
  sset.SelectOnScreen
  ' Пройтись по набору и перекрасить его в синий
  Dim entry As AcadEntity
  For Each entry In sset
    entry.Color = acBlue: entry.Update
  Next entry
  ThisDrawing.Application.ZoomExtents
  GoSub LISTOBJS

  Dim keyWord As String
  Dim gpCode(0) As Integer
  Dim dataValue(0) As Variant
  Dim groupCode As Variant, dataCode As Variant

  ThisDrawing.Utility.InitializeUserInput 1, "RemoveItem Clear Delete Erase Quit"
  keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf  "RemoveItem/Clear/Delete/Erase/Quit")

  Select Case keyWord
  Case "RemoveItem"
    ' отбор по группе (62) Цвет, номер цвета (5) - синий
    gpCode(0) = 62: dataValue(0) = 5
    ' Методу будут передаваться переменные типа вариант, ссылающиеся на массивы
    groupCode = gpCode: dataCode = dataValue
    ' Собственно отбор по цвету
    sset.Select acSelectionSetAll, , , groupCode, dataCode
    GoSub LISTOBJS
    vsego = sset.Count - 1
    ' Если размер массива removeObjects задать больше чем число
    ' объектов в наборе, то метод RemoveItems выдаст ошибку, поэтому ReDim
    ReDim removeObjects(0 To vsego) As AcadEntity
    ' пройтись по SelectionSet
    For i = 0 To vsego
      Set removeObjects(i) = sset.Item(i)
      ' установить ссылки на объекты которые исключим из набора
      ' а именно те, что разукрасили синим
    Next

    GoSub LISTOBJS
    sset.RemoveItems removeObjects
    GoSub LISTOBJS

  Case "Clear": sset.Clear: GoSub LISTOBJS

  Case "Delete": sset.Delete: GoSub LISTOBJS

  Case "Erase": sset.Erase: GoSub LISTOBJS

  Case Else
  Exit Sub

  End Select

  sset.Delete
  Exit Sub

LISTOBJS:
  If sset.Count = 0 Then
     MsgBox "набор пуст"
  Else
     MsgBox "Набор содержит: "  sset.Count  " объектов"
  End If
  Return

ErrHandle:
  MsgBox Err.Description
End Sub

Копирование объектов

Объекты рисунка могут быть копированы, в том числе на определенное смещение от оригинала. Можно так же создать зеркальное отображение объекта относительно заданной линии. Объекты могут размножаться через прямоугольный или округлый шаблон. Нельзя только использовaть эти методы одновременно с перебором элементов коллекции, сначала следует завершить перебор. Для копирования единичного объекта метод Copy позволяет создать его дубликат по тем же координатам.

Копирование нескольких объектов или в другой документ

Для этого есть метод CopyObjects или копирование через создание массива а потом методом Copy. Для копирования объектов набора, перебором его элементы засылаются в массив. Перебирая элементы массива, каждый копируется по отдельности в другой массив. Пример копирования нескольких:

Sub CopyCircleObjects()
  Dim ACADApp As AcadApplication
  Dim DOC1 As AcadDocument
  Dim circleObj1 As AcadCircle,circleObj2 As AcadCircle
  Dim circleObj1Copy As AcadCircle,circleObj2Copy As AcadCircle
  Dim centerPoint(0 To 2) As Double
  Dim radius1 As Double,radius2 As Double
  Dim radius1Copy As Double,radius2Copy As Double
  Dim objCollection(0 To 1) As Object
  Dim retObjects As Variant

  ' Определим окружность
  centerPoint(0) = 0: centerPoint(1) = 0: centerPoint(2) = 0
  radius1 = 5#: radius2 = 7#
  radius1Copy = 1#: radius2Copy = 2#

  ' Получим ссылку на объект Application
  Set ACADApp = GetObject(, "AutoCAD.Application")
  ' Создадим новый рисунок
  Set DOC1 = ACADApp.Documents.Add
  ' Добавим в него пару окружностей
  Set circleObj1 = DOC1.ModelSpace.AddCircle(centerPoint, radius1)
  Set circleObj2 = DOC1.ModelSpace.AddCircle(centerPoint, radius2)
  ZoomExtents

  ' Поместим копируемые объекты в форму совместимую с CopyObjects
  Set objCollection(0) = circleObj1
  Set objCollection(1) = circleObj2
  ' Копируем и получаем новую коллекцию
  retObjects = DOC1.CopyObjects(objCollection)
  ' Получаем вновь созданные объекты и применяем свойства к копиям
  Set circleObj1Copy = retObjects(0)
  Set circleObj2Copy = retObjects(1)
  circleObj1Copy.Radius = radius1Copy
  circleObj1Copy.Color = acRed
  circleObj2Copy.Radius = radius2Copy
  circleObj2Copy.Color = acRed
  ZoomExtents
End Sub

Смещение объектов

Смещение объекта создает его копию на определенном расстоянии от оригинала. Смещению могут подвергаться дуги, окружности, эллипсы, линии, полилинии, сплайны и некоторые другие. Метод Offset принимает единственный параметр - это дистанция на которую следует сместить объект. Если его значение отрицательное, AutoCAD пытается построить уменьшенный объект (для окружностей), если это не имеет смысла, то объект строится с координатами меньшими текущего. Для многих объектов результат операции - новая кривая, которая может не быть подобной оригиналу. Например при смещении эллипса образуется сплайн. В некоторых случаях может потребоваться чтобы смещение создало несколько кривых, поэтому метод может создавать массив объектов. Пример смещения полилини

Sub OffsetPolyline()
  Dim plineObj As AcadLWPolyline
  Dim points(0 To 11) As Double
  points(0) = 1: points(1) = 1
  points(2) = 1: points(3) = 2
  points(4) = 2: points(5) = 2
  points(6) = 3: points(7) = 2
  points(8) = 4: points(9) = 4
  points(10) = 4: points(11) = 1
  Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
  plineObj.Closed = True
  ZoomExtents

  Dim offsetObj As Variant
  offsetObj = plineObj.Offset(0.25)
  offsetObj(0).Color = acRed
  ZoomExtents

End Sub

Отражение объекта

Данный метод создает зеркальную копию объекта относительно координатной оси или заданной линии. Действует на любые объекты. В отличие от команды Mirror метод Mirror не удаляет оригинальный объект, для удаления следует воспользоваться методом Erase. Принимает два параметра - координаты точек принадлежащих линии относительно которой будет отражаться объект.

Для управления свойствами отражения текстовых объектов используется системная переменная MIRRTEXT. Значение по умолчанию 1, говорит о том, что текст отражается как и другие объекты, а значение 0 приводит к тому, что текст не меняется при отражении объекта его содержащего. Пример отражения полилини по оси:

Sub MirrorPolyline()
  Dim plineObj As AcadLWPolyline
  Dim points(0 To 11) As Double
  points(0) = 1: points(1) = 1
  points(2) = 1: points(3) = 2
  points(4) = 2: points(5) = 2
  points(6) = 3: points(7) = 2
  points(8) = 4: points(9) = 4
  points(10) = 4: points(11) = 1
  Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
  plineObj.Closed = True
  ZoomExtents

  ' Определим ось отражения
  Dim point1(0 To 2) As Double,point2(0 To 2) As Double
  point1(0) = 0: point1(1) = 4.25: point1(2) = 0
  point2(0) = 4: point2(1) = 4.25: point2(2) = 0

  ' Отразим полилинию и покажем другим цветом
  Dim mirrorObj As AcadLWPolyline
  Set mirrorObj = plineObj.Mirror(point1, point2)
  mirrorObj.Color = acRed
  ZoomExtents
End Sub

Создание массива объектов

Объект могут быть помещены в полярный или прямоугольный массив. Для полярного массива можно менять количество объектов и угол, для прямоугольного - число строк и столбцов, а так же расстояние между ними.

Создание полярного массива

Метод ArrayPolar выбранного объекта требует количество объектов, угол и центральную точку массива. Число объектов должно быть не меньше 1, угол в радианах не равный нулю (положительный угол против часовой стрелки), центр массива - переменная типа Variant, содержащая массив координат Double. AutoCAD определяет расстояние от центральной точки массива до референс-точки исходного объекта. Референс-точка зависит от типа объекта. (Для окружности и дуги это центр, для блока - точка вставки, для текста - начальная точка и т.д) Данный метод не поддерживает вращение в процессе копирования в отличие от команды ARRAY. Пример создания полярного массива

Sub ArrayingACircle()
  Dim circleObj As AcadCircle
  Dim center(0 To 2) As Double, radius As Double
  center(0) = 2#: center(1) = 2#: center(2) = 0#: radius = 1
  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
  ZoomExtents

  ' Задаем полярный массив
  Dim noOfObjects As Integer
  Dim angleToFill As Double
  Dim basePnt(0 To 2) As Double
  noOfObjects = 4
  angleToFill = 3.14 ' 180 градусов
  basePnt(0) = 4#: basePnt(1) = 4#: basePnt(2) = 0#

  ' Создаем 4 копии объекта, вращением и копированием
  ' относительно точки (3,3,0).
  Dim retObj As Variant
  retObj = circleObj.ArrayPolar(noOfObjects, angleToFill, basePnt)
  ZoomExtents
End Sub

Создание прямоугольного массива

Метод ArrayRectangular позволяет создать двумерный или трехмерный прямоугольный массив. Он требует число строк, столбцов, расстояния между ними, при создании трехмерного массива требуется так же указать количество уровней и расстояния между ними. Если задать одну строку, то следует указать несколько столбцов и наоборот. Предполагается что оригинальный объект расположен в левом нижнем углу массива, а сам массив создается вверх и вправо. Если нужно вниз и влево, задавай отрицательные расстояния между строками и столбцами.

AutoCAD строит прямоугольный массив вдоль базовой линии, определенной текущим углом привязки. По умолчанию равен нулю, столбцы и строки ортогональны в соответствии с расположением осей XY. Для изменения этого угла есть свойство SnapRotationAngle . Пример трехмерного прямоугольного массива

Sub ArrayRectangularExample()
  Dim circleObj As AcadCircle
  Dim center(0 To 2) As Double, radius As Double
  center(0) = 2#: center(1) = 2#: center(2) = 0#: radius = 0.5
  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
  ZoomExtents

  ' Определим прямоугольный массив
  Dim numOfRows As Long, numOfColumns As Long, numOfLevels As Long
  Dim distBwtnRows As Double, distBwtnColumns As Double, distBwtnLevels As Double
  numOfRows = 5: numOfColumns = 5: numOfLevels = 2
  distBwtnRows = 1: distBwtnColumns = 1: distBwtnLevels = 1

  ' Создадим массив
  Dim retObj As Variant
  retObj = circleObj.ArrayRectangular(numOfRows, numOfColumns, numOfLevels,_
  distBwtnRows, distBwtnColumns, distBwtnLevels)
  ZoomExtents
End Sub

Перемещение объектов

Объекты можно перемещать вдоль вектора без изменения размера и ориентации, а так же вращать вокруг базовой точки. Метод Move требует двух координат, задающих вектор - как далеко и в каком направлении будет движение.

Sub MoveCircle()
  Dim circleObj As AcadCircle
  Dim center(0 To 2) As Double
  Dim radius As Double
  center(0) = 2#: center(1) = 2#: center(2) = 0#: radius = 0.5
  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
  ZoomExtents

  ' Определим точки задающие вектор перемещения.
  ' (на 2 единицы вдоль оси X)
  Dim point1(0 To 2) As Double,point2(0 To 2) As Double
  point1(0) = 0: point1(1) = 0: point1(2) = 0
  point2(0) = 2: point2(1) = 0: point2(2) = 0

  circleObj.Move point1, point2
  circleObj.Update
End Sub

Вращение объектов

Метод Rotate требует координаты базовой точки в виде переменной типа Variant, содержащей массив из 3-х координат и угол в радианах - на какой повернуть от текущего положения. Пример вращения полилини относительно базовой точки

Sub RotatePolyline()
  Dim plineObj As AcadLWPolyline
  Dim points(0 To 11) As Double
  points(0) = 1: points(1) = 2: points(2) = 1: points(3) = 3
  points(4) = 2: points(5) = 3: points(6) = 3: points(7) = 3
  points(8) = 4: points(9) = 4: points(10) = 4: points(11) = 2
  Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
  plineObj.Closed = True
  ZoomExtents

  msgbox "А теперь на 45 градусов"
  ' Зададим угол в 45 градусов и базовую точку (4, 4.25, 0)
  Dim basePoint(0 To 2) As Double
  Dim rotationAngle As Double
  basePoint(0) = 4: basePoint(1) = 4.25: basePoint(2) = 0
  rotationAngle = 0.7853981   ' 45 градусов

  ' Повернем
  plineObj.Rotate basePoint, rotationAngle
  plineObj.Update
  ZoomExtents

End Sub

Удаление объектов

Отдельный объект можно удалить методом Delete. Нельзя удалить только объекты-коллекции ModelSpace, Layers, Dictionaries.

Sub DeletePolyline()
  Dim lwpolyObj As AcadLWPolyline
  Dim vertices(0 To 5) As Double
  vertices(0) = 2: vertices(1) = 4
  vertices(2) = 4: vertices(3) = 2
  vertices(4) = 6: vertices(5) = 4
  Set lwpolyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(vertices)
  ZoomExtents
  lwpolyObj.Delete
  ThisDrawing.Regen acActiveViewport
End Sub

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

Масштабирование объектов возможно указанием базовой точки и длины которые берутся как фактор масштабирования основываясь на текущих единицах измерения. Метод ScaleEntity масштабирует объект пропорционально по всем осям. Он требует укaзания базовой точки и фактора масштабирования. Базовая точка как обычно переменная типа Variant. Фактор масштабирования - величина на которую умножаются размеры объекта. Может быть от нуля до 1 (уменьшение) и больше 1 (увеличение). Пример масштабирования полилинии.

Sub ScalePolyline()
  Dim plineObj As AcadLWPolyline
  Dim points(0 To 11) As Double
  points(0) = 1: points(1) = 2: points(2) = 1: points(3) = 3
  points(4) = 2: points(5) = 3: points(6) = 3: points(7) = 3
  points(8) = 4: points(9) = 4: points(10) = 4: points(11) = 2
  Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
  plineObj.Closed = True
  ZoomExtents

  ' Зададим масштабирование
  Dim basePoint(0 To 2) As Double
  Dim scalefactor As Double
  basePoint(0) = 4: basePoint(1) = 4.25: basePoint(2) = 0: scalefactor = 0.5
  ' Масштабируем
  plineObj.ScaleEntity basePoint, scalefactor
  plineObj.Update
End Sub

Трансформировние объектов

Перед трансформацией объекта следует заполнить матрицу трансформации. В следующем примере объект вращается на 90 градусов вокруг точки (0,0,0) используя матрицу трансформации.

Sub TransformBy()
  Dim lineObj As AcadLine
  Dim startPt(0 To 2) As Double, endPt(0 To 2) As Double
  startPt(0) = 2: startPt(1) = 1
  startPt(2) = 0: endPt(0) = 5
  endPt(1) = 1: endPt(2) = 0
  Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
  ZoomAll

  ' Заполняем матрицу
  Dim transMat(0 To 3, 0 To 3) As Double
  transMat(0, 0) = 0#: transMat(0, 1) = -1#
  transMat(0, 2) = 0#: transMat(0, 3) = 0#
  transMat(1, 0) = 1#: transMat(1, 1) = 0#
  transMat(1, 2) = 0#: transMat(1, 3) = 0#
  transMat(2, 0) = 0#: transMat(2, 1) = 0#
  transMat(2, 2) = 1#: transMat(2, 3) = 0#
  transMat(3, 0) = 0#: transMat(3, 1) = 0#
  transMat(3, 2) = 0#: transMat(3, 3) = 1#

  ' Трансформируем линию
  lineObj.TransformBy transMat
  lineObj.Update
  ZoomExtents
End Sub

Еще ряд примеров матриц трансформации:

Удлинение и подрезка объектов

Можно изменять угол дуги и длину незамкнутых линий, дуг, полилиний, сплайнов и эллиптических дуг. Удлинение и подрезка объектов выполняется изменением их соответствующих свойств. К примеру для удлинения линии просто меняются координаты в свойствах StartPoint и EndPoint, для изменения угла дуги меняются свойства StartAngle и EndAngle. Чтобы отобразить изменения есть метод Update. Пример изменения длины линии

Sub LengthenLine()
  Dim lineObj As AcadLine
  Dim startPoint(0 To 2) As Double,endPoint(0 To 2) As Double
  startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0
  endPoint(0) = 1: endPoint(1) = 1: endPoint(2) = 1
  Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
  lineObj.Update

  ' Удлиним линию сменив конечную точку в 4, 4, 4
  endPoint(0) = 4: endPoint(1) = 4: endPoint(2) = 4
  lineObj.endPoint = endPoint
  lineObj.Update
End Sub

Взрывание объектов

Взрывание составных объектов приводит к их конвертации в составляющие компоненты. К примеру, взрывание создает дуги и линии из полилиний, регионов или заменяет блочные ссылки на объекты, из которых состоял блок. Взорванный объект может выглядеть точно так, как и составной, однако цвет и тип линий может и меняться. Метод Explode при взрыве полилинии отбрасывает информацию о ее толщине, полученные линии и дуги проходят по срединной линии бывшей полилинии. Если блок состоял из полилиний, то его приходится взрывать дважды. Блоки, вставленные с неравными масштабами по осям, могут при взрывании создавать непредсказуемые объекты. Нельзя взорвать xref-ссылки. При взрывании блока с атрибутами последние пропадают, однако определения атрибутов остаются. Значения атрибутов и любые модификации теряются. Пример взрыва полилинии

Sub ExplodePolyline()
  Dim plineObj As AcadLWPolyline
  Dim points(0 To 11) As Double
  points(0) = 1: points(1) = 1: points(2) = 1: points(3) = 2
  points(4) = 2: points(5) = 2: points(6) = 3: points(7) = 2
  points(8) = 4: points(9) = 4: points(10) = 4: points(11) = 1

  ' Рисуем полилинию
  Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)

  ' Видоизменяем один из сегментов
  plineObj.SetBulge 3, -0.5
  plineObj.Update
  ZoomExtents
  ' Взрываем
  Dim explodedObjects As Variant
  explodedObjects = plineObj.Explode
  ' Проходим по взорванному объекту, отображая
  ' тип каждого полученного объекта другим цветом
  Dim I As Integer
  For I = 0 To UBound(explodedObjects)
    explodedObjects(I).Color = acRed
    explodedObjects(I).Update
    MsgBox "Тип объекта "  I  ": "  explodedObjects(I).ObjectName
    explodedObjects(I).Color = acByLayer
    explodedObjects(I).Update
  Next
End Sub

Редактирование полилиний

Двумерные и трехмерные полилинии, прямоугольники, полигоны, являются вариантами полилинии и посему редактируются одинаково - разрывать, замыкать, добавлять, удалять вершины, утолщать отдельный сегмент, менять тип линии и т.д. возможно как для всей полилинии, так и для каждого ее сегмента. Можно присоединить линию, дугу или любую другую полилинию к незамкнутой полилинии. Если линия пересекает полилинию в форме буквы Т, то объект не может быть объединен. Если две линии встречаются с полилинией в форме буквы Y, одну из них AutoCAD может присоединить к полилинии. AutoCAD отбрасывает информацию сплайна, при присоединении его к другой полилинии. Когда объединение завершено, можно задать новый сплайн для результата.

Для редактирования полилинии используются следующие свойства и методы:

Пример редактирования полилинии.

Sub EditPolyline()
  Dim plineObj As AcadLWPolyline
  Dim points(0 To 9) As Double
  points(0) = 1: points(1) = 1: points(2) = 1: points(3) = 2
  points(4) = 2: points(5) = 2: points(6) = 3: points(7) = 2
  points(8) = 4: points(9) = 4
  ' Create a light weight Polyline object
  Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)

  ' задать скос для сегмента 3
  plineObj.SetBulge 3, -0.5
  ' задать новую вершину
  Dim newVertex(0 To 1) As Double
  newVertex(0) = 4: newVertex(1) = 1
  plineObj.AddVertex 5, newVertex

  ' задать ширину сегмента 4
  plineObj.SetWidth 4, 0.1, 0.5

  ' замкнуть полилинию
  plineObj.Closed = True
  plineObj.Update
  ZoomExtents
End Sub

Редактирование сплайнов

Для получения более гладких сплайнов можно добавлять дополнительные точки изгиба или менять местоположение существующих. Метод SetFitPoint пригодится в последнем случае. Свойства и методы меняющие характеристик сплайна

Sub ChangeSplineControlPoint()
  Dim splineObj As AcadSpline
  Dim noOfPoints As Integer
  Dim startTan(0 To 2) As Double
  Dim endTan(0 To 2) As Double
  Dim fitPoints(0 To 8) As Double

  noOfPoints = 3
  startTan(0) = 0.5: startTan(1) = 0.5: startTan(2) = 0
  endTan(0) = 0.5: endTan(1) = 0.5: endTan(2) = 0
  fitPoints(0) = 1: fitPoints(1) = 1: fitPoints(2) = 0
  fitPoints(3) = 5: fitPoints(4) = 5: fitPoints(5) = 0
  fitPoints(6) = 10: fitPoints(7) = 0: fitPoints(8) = 0
  Set splineObj = ThisDrawing.ModelSpace.AddSpline(fitPoints, startTan, endTan)
  splineObj.Update
  ZoomExtents
  ' Изменим координаты первой контрольной точки
  Dim controlPoint(0 To 2) As Double
  controlPoint(0) = 0: controlPoint(1) = 3: controlPoint(2) = 0
  splineObj.SetControlPoint 0, controlPoint
  splineObj.Update
End Sub

Редактирование штриховки

Можно редактировать как границу штриховки так и образец ее заполнения. Если редактируется граница ассоциативной штриховки, образец обновляется только когда заданы допустимые границы. Ассоциативная штриховка обновляется даже если она находится на отключенном слое. Можно редактировать или выбрать новый образец штриховки, однако ассоциативность может быть установлена только при создании штриховки. Свойство AssociativeHatch позволяет проверить является ли штриховка ассоциированной. Чтобы увидеть изменения в штриховке есть метод Evaluate.

Редактирование границ штриховки

Можно добавлять внутренние и внешние петли штриховкам, при этом ассоциативная штриховка обновляется, как только изменились ее границы, а не ассоциативная не обновляется. Для редактирования границ есть следующие методы:

Sub AppendInnerLoopToHatch()
  Dim hatchObj As AcadHatch
  Dim pName As String
  Dim pType As Long
  Dim bAssociativity As Boolean

  ' Определим и создадим штриховку
  pName = "ANSI31"
  pType = 0
  bAssociativity = True
  Set hatchObj = ThisDrawing.ModelSpace.AddHatch(pType, pName, bAssociativity)
  ' Создадим внешнюю петлю
  Dim outLoop(0 To 1) As AcadEntity
  Dim center(0 To 2) As Double
  Dim radius As Double, startAngle As Double, endAngle As Double
  center(0) = 5: center(1) = 3: center(2) = 0: radius = 3
  startAngle = 0: endAngle = 3.141592
  Set outLoop(0) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle)
  Set outLoop(1) = ThisDrawing.ModelSpace.AddLine(outLoop(0).StartPoint,outLoop(0).EndPoint)

  ' Добавим внешнюю петлю к штриховке
  hatchObj.AppendOuterLoop (outLoop)

  ' Создадим внутреннюю петлю
  Dim innerLoop(0) As AcadEntity
  center(0) = 5: center(1) = 4.5: center(2) = 0: radius = 1
  Set innerLoop(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)

  ' Добавм окружность как внутреннюю петлю
  hatchObj.AppendInnerLoop (innerLoop)

  ' Перемситем и отобразим штриховку
  hatchObj.Evaluate
  ThisDrawing.Regen True
End Sub

Редактирование образца штриховки

Для образца штриховки можно менять некоторые свойства (например угол, интервалы). AutoCAD для уменьшения размера файла штриховку хранит не в виде множества подобных объектов, а как один повторяющийся по определенным правилам. Имеются следующие свойства и методы:

Пример

Sub ChangeHatchPatternSpace()
  Dim hatchObj As AcadHatch
  Dim patternName As String
  Dim PatternType As Long
  Dim bAssociativity As Boolean

  ' Зададим штриховку
  patternName = "ANSI31"
  PatternType = 0
  bAssociativity = True
  ' Создадим ассациированный объект
  Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)

  ' Создадим внешнюю петлю
  Dim outLoop(0 To 0) As AcadEntity
  Dim center(0 To 2) As Double
  Dim radius As Double
  center(0) = 5: center(1) = 3: center(2) = 0: radius = 100
  Set outLoop(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
  hatchObj.AppendOuterLoop (outLoop)
  hatchObj.Evaluate

  ' Изменим шаг образца штриховки на +2
  hatchObj.PatternSpace = hatchObj.PatternSpace + 2
  hatchObj.Evaluate
  ThisDrawing.Regen True
  ZoomExtents
End Sub

Слои, цвета и типы линий

Слои подобны прозрачным пленкам на которых разложены различные группы элементов. Любой созданный объект имеет свойства: Слой, Цвет, Тип Линии. Цвет позволяет различать похожие объекты, тип линии позволяет быстро отличить, например, центральные и скрытые линии. Раскладка объектов по слоям упрощает работу над сложными чертежами.

Работа со слоями

Любое вычерчивание происходит на каком-либо слое, это может быть слой по умолчанию либо же созданный вами слой. Каждый слой имеет назначенный ему цвет и тип линии. При необходимости слой можно отключить, упростив чертеж. При работе с пространством листа или плавающим видовым экраном видимость слоев можно менять индивидуально для каждого видового экрана. При необходимости можно создать шаблон с определенным набором слоев.

Сортировка слоев и типов линий

Все слои и типы линий хранятся в соответствующих коллекциях. Поэтому можно выполнять их перебор пройдя по содержимому коллекции и получить все слои и типы линий рисунка. Пример:

Sub IteratingLayers()
  Dim layerNames As String
  Dim entry As AcadLayer
  layerNames = ""
  For Each entry In ThisDrawing.Layers
    layerNames = layerNames + entry.Name + vbCrLf
  Next
  MsgBox "Слои рисунка: " + vbCrLf + layerNames
End Sub

Создание слоя и присвоение ему имени

Для нового чертежа AutoCAD создает специальный слой с именем "0", по умолчанию ему назначается цвет = 7 (черный или белый в зависимости от цвета фона) и тип линий continuous. Данный слой не может быть удален. Вы же можете создавать новые слои и назначать им цвета и типы линий по своему усмотрению. Каждый слоя является часть коллекции Layers, для создания слоя и добавления его в коллекцию есть метод Add. При создании слою можно сразу назначить имя или переименовать его впоследствии изменив свойство Name. Имя слоя может быть не больше 31 символа, пробелы недопустимы. Пример назначения объекту другого слоя.

Sub NewLayer()
  ' Создадим окружность
  Dim circleObj As AcadCircle
  Dim center(0 To 2) As Double
  Dim radius As Double
  center(0) = 2: center(1) = 2: center(2) = 0: radius = 1
  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
  ZoomExtents
  ' Назначим окружности цвет "ByLayer" (по слою)
  circleObj.Color = acByLayer
  ' Создадим слой "ABC"
  Dim layerObj As AcadLayer
  Set layerObj = ThisDrawing.Layers.Add("ABC")
  ' назначим ему красный цвет
  layerObj.Color = acRed

  ' назначим окружности слой "ABC"
  circleObj.Layer = "ABC"
  circleObj.Update
  ' окружность изменила цвет (!)
End Sub

Установка активного слоя

В рисунке всегда один из слоев активный, новые объекты создаются на нем. Можно изменить активный слой установив у него свойство ActiveLayer, замороженный слой не может стать активным.

Dim newlayer As AcadLayer
Set newlayer = ThisDrawing.Layers.Add("LAYER1")
ThisDrawing.ActiveLayer = newlayer

Управление видимостью слоев

AutoCAD не отображает и не выводит на печать объекты расположенные на невидимых слоях. Чтобы не выводить на печать ненужные детали или чтобы они не мешались при работе слой с ними можно отключить или заморозить. Что именно выбрать - зависит от чертежа и от того как вы привыкли работать. Например заморозить можно слои которые долго не понадобятся. На печать можно вывести только размороженный и включенный слой.

Включение и выключение слоев

Sub LayerInvisble()
  Dim circleObj As AcadCircle
  Dim center(0 To 2) As Double
  Dim radius As Double
  center(0) = 2: center(1) = 2: center(2) = 0: radius = 1
  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
  circleObj.Color = acByLayer

  Dim layerObj As AcadLayer
  Set layerObj = ThisDrawing.Layers.Add("ABC")
  layerObj.Color = acRed

  circleObj.Layer = "ABC"
  circleObj.Update

  ' отключим слой "ABC"
  layerObj.LayerOn = False
  ThisDrawing.Regen acActiveViewport
End Sub

Заморозка и разморозка слоев

Заморозка слоя ускоряет прорисовку чертежа, увеличат скорость отбора объектов и уменьшает время регенерации сложных чертежей. AutoCAD не отображает, не выводит на печать и не регенерирует объекты на замороженных слоях. Замораживайте те слои которые долго не понадобятся в работе. Свойство Freeze управляет заморозкой и разморозкой. Пример

Sub LayerFreeze()
  Dim layerObj As AcadLayer
  Set layerObj = ThisDrawing.Layers.Add("ABC")
  layerObj.Freeze = True
End Sub

Блокировка и разблокировка слоев

Блокировка слоя полезна, когда необходимо редактировать объекты других слоев, но при этом видеть без возможности изменения объекты других слоев. Если слой только блокирован, а не отключен и не заморожен - объекты на нем видны. Блокированный слой можно сделать текущим и добавить на него объекты (!). Но удалить вновь добавленный объект нельзя до тех пор, пока слой не будет разблокирован. Для заблокированного слоя можно менять цвет и тип линий. Для блокировки и разблокировки слоя используется свойство Lock.

Sub LayerLock()
  Dim layerObj As AcadLayer
  Set layerObj = ThisDrawing.Layers.Add("ABC")
  layerObj.Lock = True
End Sub

Назначение слою цвета

При назначении цвета слою следует вводить имя цвета или его индекс. Стандартные имена имеются только для цветов с индексами от 1 до 7. Цвет объекту можно назначать независимый от цвета слоя. Значение индекса цвета от 0 до 256, именованные константы только для цветов 1 до 7 и Byblock и Bylayer. Если используется AcbyBlock, AutoCAD вычерчивает новые объекты в цвете по умолчанию до тех пор, пока они не группируются в блок. Когда же блок вставляется в рисунок, объекты, входящие в него, наследуют свойство цвета от блока.

Назначение типа линий для слоя

Тип линий это повторяющийся образец из черточек, точек и пробелов, созданный для того чтобы отличать различные линии на чертеже. Имя и определение типа линий описывают отдельный образец-последовательность, относительную длину и включенные текстовые фрагменты или формы (shapes) для сложных типов линий. Для назначения слою типа линий есть свойство Linetype.

Удаление слоя

Для удаления слоя есть метод Delete. Нельзя удалить текущий слой, нулевой слой, слой зависящий от внешних ссылок и слой содержащий объекты. Слои, ссылающиеся на определение блока, называемые Defpoints, не могут быть удалены, даже если не содержат видимых объектов.

Работа с цветами

Цвет можно назначить слою или отдельному объекту, цвета определяются именами или индексами от 1 до 255 (кроме того 256 - по слою, 0 - по блоку). Стандартные имена цветов: 1 - красный, 2 - желтый, 3 - зеленый, 4 - синий, 5 - голубой, 6 - магента, 7 - черный или белый. Для установки цвета используй свойство Color.

Работа с типами линий

Тип линии представляет повторяющийся последовательности точек, тире и пробелов. Сложные типы линий включают так же символы. Описание типа линий включает эти последовательности и расстояния между их отдельными элементами, а так же их размеры. Можно создавать собственные типы линий. Перед использованием типа линии их следует загрузить в чертеж. Определение типа линий должно храниться в LIN-файле-библиотеке. Загружаются они методом Load. Пример:

Sub LoadLinetype()
  On Error GoTo ERRORHANDLER
  Dim linetypeName As String
  linetypeName = "CENTER"
  ' Загрузим тип линии "CENTER" из файла acad.lin
  ThisDrawing.Linetypes.Load linetypeName, "acad.lin"
  Exit Sub

ERRORHANDLER:
  MsgBox Err.Description
End Sub

Не стоит смешивать внутренние типы линий AutoCAD с типами линий некоторых плоттеров, их совместное использование может привести к непредсказуемым результатам.

Установка активного типа линий

Чтобы использовать загруженный тип линий его следует сделать активным. Все вновь создаваемые объекты рисуются активным типом линий. Если выбрано "по слою" вновь создаваемые объекты используют активный тип линий, если выбрано "по блоку" новые объекты рисуются используя активный тип линий до тех пор пока не будут объединены в блок. Свойство ActiveLineType устанавливает активный тип линий.

ThisDrawing.ActiveLinetype = ThisDrawing.Linetypes.Item("CONTINUOUS") 

Переименование типа линий

При переименовании типа линий меняется имя только определения типа линий, в файле LINE все остается без изменений. Для переименования применяется свойство Name.

Удаление типа линий

В любой момент можно удалить тип линий, кроме следующих: Bylayer, Byblock, Continuous, текущей и зависящей от внешней ссылки. Также нельзя удалить тип линии, которая входит в определение блока. Для удаления используется метод Delete.

Изменение описания типа линий

Типы линий могут иметь описание, которое можно изменить через свойство Description. Описание может содержать до 47 символов?

 ThisDrawing.ActiveLinetype.Description = "Внешняя стена" 

Задание масштаба типа линий

Чем меньше масштаб типа линий тем более плотная линия получается на единицу рисунка. По-умолчанию AutoCAD использует масштаб равный 1.0, для его изменения используется метод LinetypeScale. Системная переменная CELTSCALE задает масштаб типов линий для вновь создаваемых объектов. Пример:

Sub ChangeLinetypeScale()
  Dim center(0 To 2) As Double
  Dim radius As Double
  Dim circleObj As AcadCircle
  center(0) = 2: center(1) = 2: center(2) = 0: radius = 4
  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
  ' задать масштаб типа линий окружности .5
  circleObj.LinetypeScale = 0.5
  circleObj.Update
End Sub

Назначение слоев, цветов и типов линий объектам

Число слоев в рисунке и число объектов на слое виртуально неограниченно. Пример изменения слоя объекта с применением свойства Layer.

Sub MoveObjectNewLayer()
  Dim circleObj As AcadCircle
  Dim center(0 To 2) As Double
  Dim radius As Double
  center(0) = 2: center(1) = 2: center(2) = 0: radius = 1
  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
  Dim layerObj As AcadLayer
  Set layerObj = ThisDrawing.Layers.Add("ABC")
  circleObj.Layer = "ABC"
  circleObj.Update
End Sub

Константы для цвета объекта: acRed, acYellow, acGreen, acCyan, acBlue, acMagenta, acWhite. Пример изменения свойства Color у объекта:

Sub ColorCircle()
  Dim circleObj As AcadCircle
  Dim center(0 To 2) As Double
  Dim radius As Double
  center(0) = 2: center(1) = 2: center(2) = 0: radius = 1
  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
  circleObj.Color = acRed
  circleObj.Update
End Sub

Пример изменения типа линий объекта. Создается окружность, делается попытка загрузить тип линии из acad.lin. Если тип линии уже есть или файл не существует, выдается сообщение об ошибке. В итоге для окружности устанавливается нужный тип линии.

Sub ChangeCircleLinetype()
  On Error Resume Next
  Dim circleObj As AcadCircle
  Dim center(0 To 2) As Double
  Dim radius As Double
  center(0) = 2: center(1) = 2: center(2) = 0: radius = 1
  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)

  Dim linetypeName As String
  linetypeName = "CENTER"

  ' Загрузим тип линии "CENTER" из файла acad.lin
  ThisDrawing.Linetypes.Load linetypeName, "acad.lin"
  If Err.Description <> "" Then MsgBox Err.Description

  ' Назначим окружности тип линии "CENTER"
  circleObj.Linetype = "CENTER"
  circleObj.Update
  ZoomExtents
End Sub

Работа с текстом

Вставка текста в рисунок

AutoCAD предоставляет несколько возможностей по созданию текста. В простейшем случае это однострочный текст. Для длинных блоков с внутренним форматированием используется многострочный текст. Хотя вводимый текст использует текущий текстовый стиль, основанный на шрифте и его настройках по умолчанию, есть несколько способов изменить оформление.

Работа со стилями текста

Каждый текст имеет связанный с ним стиль. Стиль задает шрифт, размер, угол, ориентацию и другие характеристики текста. Атрибут стиля перечислены ниже в таблице.

Создание и изменение текстового стиля

Исключая стиль по умолчанию standard можно создавать любой собственный. Вновь вводимый текст наследует высоту, ширину, угол и др. свойства текущего стиля. После создания стиля текст имя его изменить нельзя. AutoCAD автоматически преобразует имя стиля в верхний регистр. Если не вводить имя, то оно будет Style[N] где N следующее числовое значение. Изменение текущего текстового стиля осуществляется модификацией свойств объекта TextStyle.

Если изменить ориентацию текстового стиля все ранее введенные тексты этим стилем изменят ориентацию, изменение же размера, ширины, наклона так не влияет на ранее введенный текст. Впрочем поведение довольно загадочно, иногда меняется и отображение ранее введенного текста в последнем случае. Шрифт определяет форму символов. Один шрифт может быть использован для создания различных стилей. Пример назначении текстового стиля.

Sub UpdateTextFont()
  Dim typeFace As String
  Dim Bold As Boolean
  Dim Italic As Boolean
  Dim charSet As Long
  Dim PitchandFamily As Long
  ThisDrawing.ActiveTextStyle.GetFont typeFace, Bold, Italic, charSet, PitchandFamily
  typeFace = "PlayBill"
' Установить ранее созданный текстовой стиль
  ThisDrawing.ActiveTextStyle.SetFont typeFace, Bold, Italic, charSet, PitchandFamily
  ThisDrawing.Regen acActiveViewport
End Sub

Примение шрифтов true type (ttf)

Шрифты True Type всегда выглядят со сплошной заливкой, однако на печать они могут выводиться контурами, все зависит от состояния системной переменной TEXTFILL. При экспорте рисунка в формат PostScript шрифты будут печататься как было задуманно. Для повышения производительности AutoCAD Windows печатает TrueType шрифты непосредстенно, но в следствии ограничений Windows AutoCAD может по-своему их обрабатывать в случаях если текст перевернут, зеркально отражен и т.д. Трансформированный текст может выглядеть чуть толще чем задуманно при просмотре, но на печати должно быть все ОК.

Применение шрифтов unicode и bigfont

AutoCAD поддерживает стандарт Unicode, при котором в шрифте может содержаться до 65 тыс. символов из различных языков, правда ввести такие символы непосредственно невозможно, приходится пользоваться последовательностями \U+nnnn, где nnnn - шестнадцатиричный код символа. Все AutoCAD SHX-шрифты являются Unicode. Предыдущие релизы AutoCAD вплоть до 13, не поддерживают эту возможность. Шрифты BIGFONT используются для представления символов, алфавиты которых содержат тысячи "букв". Пример изменения файла шрифтов:

Sub ChangeFontFiles()
    ThisDrawing.ActiveTextStyle.BigFontFile = "C:/AutoCAD/Fonts/bigfont.shx"
    ThisDrawing.ActiveTextStyle.fontFile = "C:/AutoCAD/Fonts/italic.shx"
End Sub

Примечание: нельзя использовать длинные имена файлов содержащие запятую в качестве имени файла шрифта.

Установка высоты текста

Высота текста определяется размером символа в единицах вычерчивания. Значение обычно представляет размер букв верхнего регистра, исключение шрифты TrueType. Для них к высоте заглавных букв может прибавляться резевная зона для символов ударения. Причем этот размер определяется самостоятельно создателем шрифта. Кроме того для некоторых символов оставляется еще и резерв с низу (q, p, g и т.д.). Пример изменения размера шрифта текстового объекта.

Sub ChangeTextHeight()
  Dim textObj As AcadText
  Dim textString As String
  Dim insertionPoint(0 To 2) As Double
  Dim height As Double
  textString = "Hello, World."
  insertionPoint(0) = 3: insertionPoint(1) = 3: insertionPoint(2) = 0
  height = 0.5
  
  Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)

  textObj.height = 1
  textObj.Update
End Sub

Пример установки наклона для текстового объекта

Sub ObliqueText()
  Dim textObj As AcadText
  Dim textString As String
  Dim insertionPoint(0 To 2) As Double
  Dim height As Double
  textString = "Hello, World."
  insertionPoint(0) = 3: insertionPoint(1) = 3: insertionPoint(2) = 0
  height = 0.5
  
  Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)
  
  ' Изменим угол на 45 градусов (.707 радиан)
  textObj.ObliqueAngle = 0.707
  textObj.Update
  ZoomExtents
End Sub

Установка флага генерации текста

Данный флаг устанавливает режим отражения текста - "вверх ногами", зеркально или оба.

Sub ChangingTextGenerationFlag()
  Dim textObj As AcadText
  Dim textString As String
  Dim insertionPoint(0 To 2) As Double
  Dim height As Double
  textString = "Hello, World."
  insertionPoint(0) = 3: insertionPoint(1) = 3: insertionPoint(2) = 0
  height = 0.5
  Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)

  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

  textObj.TextGenerationFlag = acTextFlagBackward
  textObj.Update
  msgbox "Первая трансформация"
  textObj.TextGenerationFlag = acTextFlagUpsideDown
  textObj.Update
  msgbox "Вторая трансформация"
  textObj.TextGenerationFlag = acTextFlagUpsideDown+acTextFlagBackward
  textObj.Update
  msgbox "Обе трансформации сразу"
End Sub

Создание текста

Для создания текстового объекта используй метод AddLineText, требующий три параметра: собственно строка текста, точка вставки и высота текста. В качестве текстовой строки принимаются Unicode-символы, управляющие и специальные символы. Точка вставки - переменная типа Variant. Высота текста положительное значение в текущих единицах чертежа.

Пример:

Sub CreateText()
  Dim textObj As AcadText
  Dim textString As String
  Dim insertionPoint(0 To 2) As Double
  Dim height As Double
  textString = "Hello, World."
  insertionPoint(0) = 2: insertionPoint(1) = 2: insertionPoint(2) = 0
  height = 0.5
  Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)
  textObj.Update
End Sub

Форматирование строки текста

Изменить оформление текста можно либо изменив назначенный ему текстовый стиль, либо меняя свойства самого текстового объекта. Форматировать можно только полностью строку, а не отдельное слово. Для изменения стиля есть свойство StyleName, после его изменения следует применять метод Update. Дополнительные свойства характерные только для текстов:

Полный список свойств и методов приведен в справочной системе.

Повторное выравнивание текста

Пример создает объект Text и объект Point, последний задает точку выравнивания текста и меняется на красное перекрестие.

Sub TextAlignment()
  Dim textObj As AcadText
  Dim textString As String
  Dim insertionPoint(0 To 2) As Double
  Dim height As Double
  textString = "Hello, World."
  insertionPoint(0) = 3: insertionPoint(1) = 3: insertionPoint(2) = 0
  height = 0.5
  
  Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)
  
  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

  Dim pointObj As AcadPoint
  Dim alignmentPoint(0 To 2) As Double
  alignmentPoint(0) = 3: alignmentPoint(1) = 3: alignmentPoint(2) = 0
  Set pointObj = ThisDrawing.ModelSpace.AddPoint(alignmentPoint)
  pointObj.Color = acRed
  
  ' сменим стиль отображения точки
  ThisDrawing.SetVariable "PDMODE", 2
  ' выровняем текст влево
  textObj.Alignment = acAlignmentLeft
  ThisDrawing.Regen acActiveViewport
  MsgBox "Текст выровнян по левому краю"
  
  ' теперь по центру
  textObj.Alignment = acAlignmentCenter
  
  ' теперь по точке
  textObj.TextAlignmentPoint = alignmentPoint
  
  ThisDrawing.Regen acActiveViewport
  MsgBox "Текст центрирован"
  
  ' Теперь вправо
  textObj.Alignment = acAlignmentRight
  ThisDrawing.Regen acActiveViewport
  MsgBox "Текст выровнен по правому краю"
  
End Sub

Модификации текста

Как и любой другой объект, текст можно перемещать, вращать, стирать, копировать. Можно так же зеркально отражать, при этом если не хочется, чтобы он был вывернут наизнанку, меняем значение системной переменной MIRRTEXT на ноль. Некоторые методы текста перечисленны ниже, все остальные можно узнать из справочной системы.

Многострочный текст

Принципальное отличие многострочного текста (мультитекста) от текста в том, что форматровать можно отдельные слова и даже символы. Мультитекст может состоять из любого числа параграфов, весь блок мультитекста можно подвергнуть форматированию сразу. Так же только для мультитекста есть подчеркивание.

Создание многострочного текста

Метод AddMText требует три параметра - текстовая строка, точка вставки и ширина рамки в которую будет втиснут мультитекст. Последний параметр представляет положительное число, в единицах текущего чертежа. Высота блока мультитекста зависит от количества вводимых символов. Пример создания мультитекста.

Sub CreateMText()
  Dim mtextObj As AcadMText
  Dim insertPoint(0 To 2) As Double
  Dim width As Double
  Dim textString As String
  insertPoint(0) = 2: insertPoint(1) = 2: insertPoint(2) = 0: width = 4
  textString = "Длиная строка являющаяся примером многострочного текста."
  Set mtextObj = ThisDrawing.ModelSpace.AddMText(insertPoint, width, textString)
  ZoomExtents
End Sub

Форматирование мультитекста

Вновь вводимому тексту автоматически назначается форматирование текущего текстового стиля. (по умолчанию стиль STANDARD) Форматирование можно впоследствии изменить используя специальные символы и свойства объекта. Ориентация, выравнивание, ширина и вращение могут назначаться только целому объекту мультитекст, в отличие например от подчеркивания, которое может выделять лишь нужное слово или букву.

Форматирование отдельных символов мультитекста

Индивидуально можно менять шрифт, цвет, подчеркивание и др. атрибуты элементов мультитекста. Таблица кодов форматирующих символов приведена ниже.

В последнем примере вводится дробь 1 и 1/2. Использование фигурных скобок применяет форматирование только внутри них. Вложенность скобок может достигать 8 уровней. Пример форматирования с ASCII-кодами {{\H1.5x; Big text} \A2; over text\A1;/\A0; under text} Пример использования форматирующих символов

Sub FormatMText()
  Dim mtextObj As AcadMText
  Dim insertPoint(0 To 2) As Double
  Dim width As Double
  Dim textString As String
  
  insertPoint(0) = 2: insertPoint(1) = 2: insertPoint(2) = 0: width = 100
  
  Dim OB As Long,CB As Long,BS As Long,FS As Long,SC As Long
  OB = Asc("{")
  CB = Asc("}")
  BS = Asc("\")
  FS = Asc("/")
  SC = Asc(";")
  
  ' {{\H1.5x; Big text}\A2; over text\A1;/\A0; under text}
  
  textString = Chr(OB) + Chr(OB) + Chr(BS) + "H1.5x" _
  + Chr(SC) + "Big text" + Chr(CB) + Chr(BS) + "A2" _
  + Chr(SC) + "over text" + Chr(BS) + "A1" + Chr(SC) _
  + Chr(FS) + Chr(BS) + "A0" + Chr(SC) + "under text" _
  + Chr(CB)
  
  Set mtextObj = ThisDrawing.ModelSpace.AddMText(insertPoint, width, textString)
  ZoomExtents
End Sub

Форматирование многострочных текстовых объектов

Установка свойства объекта StyleName задает стиль по умолчанию для вновь создаваемых объектов мультитекста. При применении нового стиля к ранее созданным объектам имеющее сложное форматирование будет утеряно. Выравнивание текста бывает левое, правое и по центру, а положение вверху, внизу и по центру. AutoCAD предлагает 9 установок выравнивания: TL (вверх и влево), TC (вверх и по центру), TR (вверх и вправо), ML, MC, MR, BL, BC, BR. Изменять эти значения можно через свойство AttachmentPoint.

Использование символов unicode, управляющих и специальных символов

Символы unicode \U+00B0 градусы, \U+00B1 плюс-минус, \U+2205 диаметр. Указав %%код_символа можно вводить и другие спец-символы. %%o - надчеркивание, %%u - подчеркивание, %%d - градусы, %%p - плюс-минус, %%c - диаметр, %%% - проценты.

Замена шрифтов

Если AutoCAD не находит шрифт указанный в чертеже можно укзать другой. Для чего в любом текстовом редакторе создается таблица замены fmp-файл, каждая строка которого имеет вид romanc.shx; times.ttf (какой менять; на какой). Для указания файла замены шрифтов отличного от того, что входит в стандартную поставку AutoCAD, используйте свойство FontFileMap объекта Preferences.

Установка альтернативного шрифта по-умолчанию

По умолчанию для замены несуществующего шрифта используется simplex.shx, однако можно укзать любой другой через свойство AltFontFile объекта Preferences.

Размерности, допуски и указатели

Размерности представляют собой геометрические характеристики объектов - расстояния углы между ними. В AutoCADе их три разновидности - линейные, радиальные (от слова радиус) и угловые. Они могут создаваться как для объектов (линий, мультилиний, дуг, окружностей, сегментов полилинии) так и самостоятельно. Каждая размерность имеет свой размерный стиль, включающий цвет, тип линий, стиль текста. Переменные, определяющие вид размерностей: DIMAUNIT, DIMUPT, DIMTOFL, DIMFIT, DIMTIH, DIMTOH, DIMJUST, DIMTAD. Однострочный текст размерности использует текущий текстовый стиль. Ассациативные размерности это те, в которых все линии, стрелки, дуги и тексты рисуются как единый объект. По умолчанию системная переменная DIMASO, отвечающая за ассациативность размерностей, включена.

Создание размерностей

Можно создавать линейные, радиальные, угловые и ординатные размерности. При этом используется активный размерный стиль. Линейные размеры могут вращаться и выравниваться. Они строятся параллельно измеряемой части объекта с использованием методов AddDimAligned, AddDimRotated, AddDim3PointAligned. Для создания радиальных размеров дуг и окружностей есть метод AddDimRadial, пример построения радиальных размеров:

Sub CreateRadialDimension()
  Dim dimObj As AcadDimRadial
  Dim center(0 To 2) As Double
  Dim chordPoint(0 To 2) As Double
  Dim leaderLen As Integer
  
  center(0) = 0: center(1) = 0: center(2) = 0
  chordPoint(0) = 5: chordPoint(1) = 5: chordPoint(2) = 0
  leaderLen = 5
  
  Set dimObj = ThisDrawing.ModelSpace.AddDimRadial(center, chordPoint, leaderLen)
  ZoomExtents
End Sub

Пример создания угловых размеров

Sub CreateAngularDimension()
  Dim dimObj As AcadDimAngular
  Dim angVert(0 To 2) As Double
  Dim FirstPoint(0 To 2) As Double
  Dim SecondPoint(0 To 2) As Double
  Dim TextPoint(0 To 2) As Double
  
  angVert(0) = 0: angVert(1) = 5: angVert(2) = 0
  FirstPoint(0) = 1: FirstPoint(1) = 7: FirstPoint(2) = 0
  SecondPoint(0) = 1: SecondPoint(1) = 3: SecondPoint(2) = 0
  TextPoint(0) = 3: TextPoint(1) = 5: TextPoint(2) = 0
  
  Set dimObj = ThisDrawing.ModelSpace.AddDimAngular(angVert, FirstPoint, SecondPoint, TextPoint)
  ZoomAll
End Sub

Ординатные размеры измеряют перпиндикулярное расстояние от заданной точки до измеремого объекта. Обычно используются, чтобы избежать ошибок взаимного положения объектов.

Пример:

Sub CreatingOrdinateDimension()
  Dim dimObj As AcadDimOrdinate
  Dim definingPoint(0 To 2) As Double
  Dim leaderEndPoint(0 To 2) As Double
  Dim useXAxis As Long
  
  definingPoint(0) = 5: definingPoint(1) = 5: definingPoint(2) = 0
  leaderEndPoint(0) = 10: leaderEndPoint(1) = 5: leaderEndPoint(2) = 0
  useXAxis = 5
  
  Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(definingPoint, leaderEndPoint, useXAxis)
  ZoomExtents
End Sub

Для редактирования размеров используется следующие свойства

А в дополнение следующие методы

Пример переопределения текста размера

Sub OverrideDimensionText()
  Dim dimObj As AcadDimAligned
  Dim point1(0 To 2) As Double
  Dim point2(0 To 2) As Double
  Dim location(0 To 2) As Double
  
  ' задаем размер
  point1(0) = 5#: point1(1) = 3#: point1(2) = 0#
  point2(0) = 10#: point2(1) = 3#: point2(2) = 0#
  location(0) = 7.5: location(1) = 5#: location(2) = 0#
  
  Set dimObj = ThisDrawing.ModelSpace.AddDimAligned(point1, point2, location)
  
  ' меняем текст
  dimObj.TextOverride = "Значение <>"
  dimObj.Update
End Sub

Работа с размерными стилями

Именованный размерный стиль - группа настроек определяющих вид размеров. Создание нового стиля осуществляется методом Add, метод CopyFrom позволяет копировать стиль. При этом если копировать стиль не с объекта Style, а с объекта Document, то переносятся все переопределения стиля.

Пример копирования стиля с переопределениями. Он создает три размерных стиля и копирует их при разных установках. Для его работы следует в новом рисунке создать линейный размер, изменить цвет на желтый, изменить значение системной переменной DIMCLRD на 5.

Sub CopyDimStyles()
  Dim newStyle1 As AcadDimStyle,newStyle2 As AcadDimStyle
  Dim newStyle3 As AcadDimStyle
  
  Set newStyle1 = ThisDrawing.DimStyles.Add ("Стиль 1 скопирован с dim")
  Call newStyle1.CopyFrom(ThisDrawing.ModelSpace(0))
  
  Set newStyle2 = ThisDrawing.DimStyles.Add ("Стиль 2 скопирован со Стиль 1")
  Call newStyle2.CopyFrom(ThisDrawing.DimStyles.Item ("Стиль 1 скопирован с dim"))
                  
  Set newStyle2 = ThisDrawing.DimStyles.Add ("Стиль 3 скопирован с настройками")
  Call newStyle2.CopyFrom(ThisDrawing)
End Sub

Если открыть диалог DIMSTYLE, то там должны появиться три разных стиля.

Переопределение размерного стиля

Следующие свойства доступны для большинства размеров:

Пример выровненного размера с суффиксом определенным пользователем:

Sub AddTextSuffix()
  Dim dimObj As AcadDimAligned
  Dim point1(0 To 2) As Double
  Dim point2(0 To 2) As Double
  Dim location(0 To 2) As Double
  Dim suffix As String
  
  ' Определим размер
  point1(0) = 0: point1(1) = 5: point1(2) = 0
  point2(0) = 5: point2(1) = 5: point2(2) = 0
  location(0) = 5: location(1) = 7: location(2) = 0
  
  Set dimObj = ThisDrawing.ModelSpace.AddDimAligned(point1, point2, location)
  
  ThisDrawing.Application.ZoomExtents
  ' Позволим пользователю сменить суффикс
  suffix = InputBox("Новый суффикс для размера", "Set Dimension Suffix", ":SUFFIX")
  
  dimObj.TextSuffix = suffix
  ThisDrawing.Regen acAllViewports
End Sub

Размерности в пространстве модели и пространстве лист

Рисовать размерности можно как в пространстве модели, так и в пространстве листа, однако если фигуры в пространстве модели, то и размеры лучьше рисовать там же. Если же рисовать размер в пространстве листа, когда фигуры нарисованы в пространстве модели, то они не меняются автоматически, когда вы используете команды редактирования и увеличения. Если вы проставляете размеры в пространстве листа, и глобальный фактор масштабирования DIMLFAC для линейных размеров меньше нуля, измеренное расстояние умножается на абсолютное значение DIMLFAC. Если размеры в пространстве модели, то используется значение 1.0, даже если DIMLFAC меньше нуля.

Создание указателей и примечаний

Указатель - это линия соединяющая примечание с какой-либо частью рисунка. указатель связан с примечанием и меняется вместе с ним, если примечание отредактировать. Не путайте объект указатель с линией-указателем автоматически создаваемой AutoCADом как часть размерной линии. Указатель может быть в форме прямого сегмента или кривой. Цвет его зависит от цвета текущих размерных линий. Масштаб его управляется общим масштабом размерностей, установленном в активном размерном стиле. Тип и размер стрелок, если они есть, управляется первой стрелкой определенной в активном размерном стиле. Малая линия, известная как крючок, обычно присоединена к примечанию, если у указателя нет примечания, то нет и крючка. Для создания указателя используется метод AddLeader, принимающий три параметра: массив координат в форме переменной типа Variant, собственно примечание, и тип определяющий форму - прямой или кривая, а так же есть у него стрелка или нет. Следующие константы определяют тип указателя: acLineNoArrow, acLineWithArrow, acSplineNoArrow, acSplineWithArrow.

Sub CreateLeader()
  Dim leaderObj As AcadLeader
  Dim points(0 To 8) As Double
  Dim leaderType As Integer
  Dim annotationObject As AcadObject
  
  points(0) = 0: points(1) = 0: points(2) = 0
  points(3) = 4: points(4) = 4: points(5) = 0
  points(6) = 4: points(7) = 5: points(8) = 0
  leaderType = acLineWithArrow
  Set annotationObject = Nothing
      
  Set leaderObj = ThisDrawing.ModelSpace.AddLeader(points, annotationObject, leaderType)
  ZoomExtents
End Sub

Добавление примечания к указателю

Примечание может быть в виде объектов Tolerance, MText, BlockRef и присоединяется к указателю только при его создании.

Ассациативность указателей

Примечание связывается с соответствующим указателем и при перемещении примечания конечная точка указателя перемещается с ним. Уничтожение обоих объектов методами Erase, Add (для блоков) и WBlock. При копировании примечания и указателя одной командой они становятся ассациативными в любом случае. Если ассациативность разрывается по любой причине, например если копируется отдельно указатель или удаляется примечание, то крючок тоже удаляется.

Sub AddAnnotation()
  Dim leaderObj As AcadLeader
  Dim mtextObj As AcadMText
  Dim points(0 To 8) As Double
  Dim insPoint(0 To 2) As Double
  Dim width As Double
  Dim leaderType As Integer
  Dim annotObj As Object
  Dim textString As String, msg As String
  
  textString = "Hello, World."
  insPoint(0) = 5: insPoint(1) = 5: insPoint(2) = 0: width = 2
  Set mtextObj = ThisDrawing.ModelSpace.AddMText(insPoint, width, textString)
  ' данные для указателя
  points(0) = 0: points(1) = 0: points(2) = 0
  points(3) = 4: points(4) = 4: points(5) = 0
  points(6) = 4: points(7) = 5: points(8) = 0
  leaderType = acLineWithArrow
     
  ' Создаем указатель и связываем с ним объект MText
  Set annotObj = mtextObj
  Set leaderObj = ThisDrawing.ModelSpace.AddLeader(points, annotObj, leaderType)
  ZoomExtents
End Sub

Редактирования ассациативности указателя

Исключая случая ассациативности указатель и его примечание являются отдельными объектами. Хотя текстовые примечания создаются с использованием системных переменных DIMCLRT, DIMTXT, DIMTXSTY определяющих их цвет, высоту и стиль они не могут быть изменены через эти переменные, т.к. на самом деле не являются объектами Размеры. Редактировать их следует теми же методами, что и обычный мультитекст. Метод Evalute обновляет размеры указателя при изменении примечания, если это необходимо.

Редактирование указателей

Любые изменения примечаний приводят к изменению конечной точки указателя. Для измения размера указателя его можно масштабировать, при этом размеры примечания остаются без изменения. Можно так же перемещать, вращать и зеркально отражать указатель.

Создание геометрических допусков

Геометрические допуски показвают возможные отклонения форм, профилей и т.д. Для их создания есть метод AddTolerance, требующий три параметра - текстовая строка, расположение и направляющий вектор. Можно так же копировать, стирать, вращать, масштабировать допуски. Пример создания:

Sub CreateTolerance()
  Dim toleranceObj As AcadTolerance
  Dim textString As String
  Dim insPoint(0 To 2) As Double
  Dim direction(0 To 2) As Double
  
  ' Define the tolerance object
  textString = "Here is the Feature Control Frame"
  insPoint(0) = 5: insPoint(1) = 5: insPoint(2) = 0
  direction(0) = 1: direction(1) = 1: direction(2) = 0
  ' Create the tolerance object in model space
  Set toleranceObj = ThisDrawing.ModelSpace.AddTolerance(textString, insPoint, direction)
  ZoomExtents
End Sub

Редактирование допусков

Допуски подвержены влиянию нескольких системных переменных: DIMCLRD, DIMCLRT, DIMGAP, DIMTXT, DIMTXTSTY

Настройка меню и панелей инструментов

Две наиболее важных коллекции, касающиеся меню MenuBar, MenuGroups. Первая содержит все отображаемые меню, вторая группы меню, часть из которых может не отражаться на экране. Группы меню могут содержать панели инструментов.

Исследование коллекции menugroups

Каждая группа меню содержит коллекции PopupMenus и Toolbars. Схема такова MenuBar-PopupMenu.MenuGroups-MenuGroup.В составе MenuGroup - PopupMenus и Toolbars.PopupMenus-PopupMenu-PopupMenuItem, Toolbars-Toolbar-ToolbarItem.

Загрузка групп меню

Выполняется методом Load, если параметр BaseMenu установлен =True, загружается новая группа меню, как основное меню аналогично команде MENU. Если этот параметр не указать, то загружается частичное меню, аналогично тому как это делает команда MENULOAD. Сразу после загрузки частичное меню может быть вставлено в панель меню методом InsertMenuInMenuBar или InsertInMenuBar. Так же становятся доступны все меню и панели инструментов входящие в меню. Далее можно;

Пример загрузки группы меню:

ThisDrawing.Application.MenuGroups.Load "acad.mnc" 

Создание новой группы меню

AutoCAD ActiveX не позволяет создавать пустую группу меню, однако можно загрузить существующую и сохранить с новым именем и в новом файле. После чего его можно отредактировать по своему желанию. Приимущество данного подхода в том, что оказываются уже созданными базовые меню Файл, Окно и Помощь. Пример сохранения группы меню в новом файле:

ThisDrawing.Application.MenuGroups.Item(0).SaveAs "MyMenu.mnc", acMenuFileCompiled 

Изменение панели меню

Основное меню может быть полностью замещено загружаемым, если оно загружается как основное меню. Кроме того могут быть модифицированы и отдельные меню. Оба метода InsertMenuInMenuBar и InsertInMenuBar преследуют одну цель. Различие между ними в объекте из которого они вызываются. Первый вызывается из коллекции PopupMenus, требует имя меню и точку вставки. Второй вызывается непосредственно из объекта PopupMenu и требует только указания точки вставки. Вам решать какой метод избрать. Пример вставки меню:

Sub InsertMenu()
  ' Определим переменную для группы меню
  Dim currMenuGroup As AcadMenuGroup
  Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

  ' Создадим меню
  Dim newMenu As AcadPopupMenu
  Set newMenu = currMenuGroup.Menus.Add("TestMenu")

  ' Определим переменную для пункта меню
  Dim newMenuItem As AcadPopupMenuItem
  Dim openMacro As String

  ' Назначим макрос аналог "ESC ESC _open " и создадим пункт меню
  openMacro = Chr(3) + Chr(3) + Chr(95) + "open" + Chr(32)
  Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "Open", openMacro)

  ' Отобразим меню
  currMenuGroup.Menus.InsertMenuInMenuBar "TestMenu", ""
End Sub

Удаление меню из панели меню

Для данной цели используйте один из следующих методов RemoveMenuFromMenuBar или RemoveFromMenuBar. Различия между ними те же что и для вышеописанных методов добавления меню. Пример удаления: currMenuGroup.Menus.RemoveMenuFromMenuBar ("TestMenu") В результате меню становятся невидимым, но физически не удаляется. Пример переупорядочивания меню (первый пункт переносится в конец):

Sub MoveMenu()
  ' Определим переменную содержащую меню
  Dim moveMenu As AcadPopupMenu
  Dim MyMenuBar As AcadMenuBar
  Set MyMenuBar = ThisDrawing.Application.menuBar

  ' установим moveMenu равным первому
  Set moveMenu = MyMenuBar.Item(0)

  ' уберем с первой позиции
  MyMenuBar.Item(0).RemoveFromMenuBar

  ' вставим в последнюю
  moveMenu.InsertInMenuBar (MyMenuBar.count)
End Sub

В результате меню File должно переехать в последнюю позицию.

Создание и редактирование выпадающих и всплывающих меню

Оба типа меню отображаются как каскадные меню. Последние, например, позволяют включать-включать объектную привязку. Выпадающие меню могут содержать до 999 пунктов. А всплывающие только до 499. Оба предела включют все меню в иерархии. Если меню не умещается на экране, то оно грубо обрезается. Всплывающие меню появляются обычно рядом с перекрестием. Если свойство ShortcutMenu=TRUE значит, это оно и есть.

Cоздание меню

Методом Add можно добавить объект PopupMenu в коллекцию PopupMenus. Для создания нового всплывающего старое следует сначала удалить. Может быть только одно такое меню на группу. Если таких меню нет, то можно создать его с именем "POP0". После чего по этому имени можно обращаться к меню в коллекции. Меню может включать и некторые специальные символы. Пример создания выпадающего меню:

Sub CreateMenu()
  Dim currMenuGroup As AcadMenuGroup
  Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)
  Dim newMenu As AcadPopupMenu
  Set newMenu = currMenuGroup.Menus.Add("TestMenu")
End Sub

Добавление пункта к меню

Метод AddMenuItem добавляет пункт в выпадающее меню, принимает четыре параметра - Index, Label, Tag, Macro. Index начинается с нуля, для добавления в конец установи индекс = значению свойства Count. Label - строка, определяющая содержание и формат пункта меню. (может содержать DEISEL выражение и специальные коды). Текст пункта меню еще называют Caption. Тэг - строка символов, включая подчеркивание идентифицирующая пункт меню. Макро - набор команд, выполняющихся при выборе пункта меню. Может быть как простым макросом вызывающим команду так и сложным набором команд. Пример добавления пункта меню:

Sub AddAMenuItem()
  Dim currMenuGroup As AcadMenuGroup
  Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)
  Dim newMenu As AcadPopupMenu
  Set newMenu = currMenuGroup.Menus.Add("TestMenu")

  ' добавим пункт
  Dim newMenuItem As AcadPopupMenuItem
  Dim openMacro As String
  ' назначим макрос эквивалентный "ESC ESC _open "
  openMacro = Chr(3) + Chr(3) + Chr(95) + "open" + Chr(32)

  Set newMenuItem = newMenu.AddMenuItem(newMenu.count + 1, "Open", openMacro)

  ' Отобразим
  newMenu.InsertInMenuBar(ThisDrawing.Application.menuBar.count + 1)
End Sub

Для добавления разделителя между пунктами меню используйте метод AddSeparator.

Доступ к горячим клавишам

Для назначения горячей клавиши используйте символ непосредственно перед буквой, которая и будет горячей. Пример:

Sub AddAMenuItem()
  Dim currMenuGroup As AcadMenuGroup
  Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)
  Dim newMenu As AcadPopupMenu
  Set newMenu = currMenuGroup.Menus.Add("Te" + Chr(Asc("")) + "stMenu")

  Dim newMenuItem As AcadPopupMenuItem
  Dim openMacro As String
  openMacro = Chr(3) + Chr(3) + Chr(95) + "open" + Chr(32)
  Set newMenuItem = newMenu.AddMenuItem(newMenu.count + 1, Chr(Asc("")) _
      + "Open", openMacro)

  newMenu.InsertInMenuBar(ThisDrawing.Application.menuBar.count + 1)
End Sub

Создание каскадных подменю

Для этой цели используйте метод AddSubmenu который создает новый объект PopupMenu и добавляет его в меню. Принимает три параметра - Index, Label и Tag. Данный метод не возвращает объект PopupMenu вместо этого он возвращает новое меню на которое указывает подменю, это меню следует добавить в существующее. Пример:

Sub AddASubMenu()
  Dim currMenuGroup As AcadMenuGroup
  Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

  Dim newMenu As AcadPopupMenu
  Set newMenu = currMenuGroup.Menus.Add("TestMenu")

  ' Добавим подменю
  Dim FileSubMenu As AcadPopupMenu
  Set FileSubMenu = newMenu.AddSubMenu("", "OpenFile")

  ' Добавим пункт в подменю
  Dim newMenuItem As AcadPopupMenuItem
  Dim openMacro As String
  openMacro = Chr(3) + Chr(3) + Chr(95) + "open" + Chr(32)
  Set newMenuItem = FileSubMenu.AddMenuItem(newMenu.count + 1, "Open", openMacro)

  ' Отобразим
  newMenu.InsertInMenuBar(ThisDrawing.Application.menuBar.count + 1)
End Sub

Удаление пункта из меню

Sub DeleteMenuItem()
  Dim LastMenu As AcadPopupMenu
  Set LastMenu = ThisDrawing.Application.menuBar. _
              Item(ThisDrawing.Application.menuBar.count - 1)

  ' Добавим пункт меню
  Dim newMenuItem As AcadPopupMenuItem
  Dim openMacro As String
  openMacro = Chr(3) + Chr(3) + Chr(95) + "open" + Chr(32)
  Set newMenuItem = LastMenu.AddMenuItem(LastMenu.count + 1, "Open", openMacro)

  ' Удалим пункт меню
  newMenuItem.Delete
End Sub

Исследование свойств пункта меню

Все пункты меню разделяют следующие свойства:

Sub DisableMenuItem()
  Dim currMenuGroup As AcadMenuGroup
  Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

  Dim newMenu As AcadPopupMenu
  Set newMenu = currMenuGroup.Menus.Add("TestMenu")

  ' Добавим два пункта и разделитель
  Dim MenuEnable As AcadPopupMenuItem
  Dim MenuDisable As AcadPopupMenuItem
  Dim MenuSeparator As AcadPopupMenuItem
  Dim openMacro As String

  ' Назначим макрос
  openMacro = Chr(3) + Chr(3) + Chr(95) + "open" + Chr(32)
  Set MenuEnable = newMenu.AddMenuItem(newMenu.count + 1, "OpenEnabled", openMacro)
  Set MenuSeparator = newMenu.AddSeparator("")
  Set MenuDisable = newMenu.AddMenuItem(newMenu.count + 1, "OpenDisabled", openMacro)

  ' Запретим второй пункт
  MenuDisable.Enable = False

  ' Отобразим
  newMenu.InsertInMenuBar(ThisDrawing.Application.menuBar.count + 1)
End Sub

Создание и редактирование панелей инструментов

Добавить кнопку на панель можно методом AddToolbarButton который принимает 5 параметров: Index, Name, HelpString, Macro, FlyoutButton (определяет будет ли панель выпадающая). Пример:

Sub AddButton()
  Dim currMenuGroup As AcadMenuGroup
  Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

  ' Создаем сначала панель
  Dim newToolbar As AcadToolbar
  Set 

newToolbar = currMenuGroup.Toolbars.Add("TestToolbar")

  ' Добавляем кнопку
  Dim newButton As AcadToolbarItem
  Dim openMacro As String

  ' Назначим макрос
  openMacro = Chr(3) + Chr(3) + Chr(95) + "open" + Chr(32)
  Set newButton = newToolbar.AddToolbarButton("", "NewButton", "Open a file.", openMacro)
End Sub

Добавление разделителя - использовать метод AddSeparator.

Назначение значка для кнопки

Для этого есть методы SetBitmap и GetBitmap, первый принимает два параметра SmallIconName (bmp-файл 15х16) и LargeIconName (bmp-файл 24х22). Пример опроса существующей панели на предмет наличия иконок у кнопок.

Sub GetButtonImages()
  Dim Button As AcadToolbarItem
  Dim Toolbar0 As AcadToolbar
  Dim MenuGroup0 As AcadMenuGroup
  Dim SmallButtonName As String,LargeButtonName As String
  Dim msg As String
  Dim ButtonType As String

  ' Первая панель в первой группе меню
  Set MenuGroup0 = ThisDrawing.Application.MenuGroups.Item(0)
  Set Toolbar0 = MenuGroup0.Toolbars.Item(0)

  SmallButtonName = "": LargeButtonName = ""

  msg = "Панель: " + Toolbar0.Name + vbCrLf
  Toolbar0.Visible = True

  ' Пройдем по коллекции, отображая имена иконок кнопок
  For Each Button In Toolbar0
      ButtonType = Choose(Button.Type + 1, "Button", "Separator", "Control", "Flyout")
      msg = msg  ButtonType  ":   "
      If Button.Type = acToolbarButton Or Button.Type = acToolbarFlyout Then
          Button.GetBitmaps SmallButtonName, LargeButtonName
          msg = msg + SmallButtonName + ", " + LargeButtonName
      End If
      msg = msg + vbCrLf
  Next Button

  MsgBox msg
End Sub

Создание выпадающей панели

Sub AddFlyoutButton()
  Dim currMenuGroup As AcadMenuGroup
  Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

  ' Создадим панель
  Dim FirstToolbar As AcadToolbar
  Set FirstToolbar = currMenuGroup.Toolbars.Add("FirstToolbar")
  ' Добавим кнопку для выпадающей панели
  Dim FlyoutButton As AcadToolbarItem
  Set FlyoutButton = FirstToolbar.AddToolbarButton _
          ("", "Flyout", "Пример выпадающей панели","OPEN", True)

  ' Создадим вторую панель и привяжем ее к кнопе первой панели
  Dim SecondToolbar As AcadToolbar
  Set SecondToolbar = currMenuGroup.Toolbars.Add("SecondToolbar")

  ' Добавим кнопку на вторую панель
  Dim newButton As AcadToolbarItem
  Dim openMacro As String

  ' Назначим макрос
  openMacro = Chr(3) + Chr(3) + Chr(95) + "open" + Chr(32)
  Set newButton = SecondToolbar.AddToolbarButton _
          ("", "NewButton", "Open a file.", openMacro)

  ' Присоединим вторую панель к кнопке первой
  FlyoutButton.AttachToolbarToFlyout currMenuGroup.Name,SecondToolbar.Name

  ' Отобразим первую панель, скрыв вторую
  FirstToolbar.Visible = True
  SecondToolbar.Visible = False
End Sub

Плавающая и пристыкованная панели

Чтобы сделать панель плавающей следует использовать метод Float, принимающий три параметра: top, left и NumberFloatRows. Для создания пристыкованной панели используйте метод Dock, принимающий три параметра: Side, Row, Column. Пример создания такой панели:

Sub DockToolbar()
  Dim currMenuGroup As AcadMenuGroup
  Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

  ' Создадим панель
  Dim newToolbar As AcadToolbar
  Set newToolbar = currMenuGroup.Toolbars.Add("TestToolbar")

  ' Добавим кнопки с одним и тем же макросом для простоты
  Dim newButton1 As AcadToolbarItem
  Dim newButton2 As AcadToolbarItem
  Dim newButton3 As AcadToolbarItem
  Dim openMacro As String

  ' Назначим макрос
  openMacro = Chr(3) + Chr(3) + Chr(95) + "open" + Chr(32)

  Set newButton1 = newToolbar.AddToolbarButton("", "NewButton1", "Open a file.", openMacro)
  Set newButton2 = newToolbar.AddToolbarButton("", "NewButton2", "Open a file.", openMacro)
  Set newButton3 = newToolbar.AddToolbarButton("", "NewButton3", "Open a file.", openMacro)

  ' Отобразим панель
  newToolbar.Visible = True

  ' Пристыкуем к левому краю экрана
  newToolbar.Dock acToolbarDockLeft
End Sub

Для удаления кнопки из панели используется метод Remove когда панель инструментов видима.

Свойства элементов панели инструментов

Tag, Name, Macro, HelpString, Index, Type (acButton, acToolButtonSeparator, acControl), Flyout, Parent, и другие - задающие пристыковку, видимость и т.д.

Создание макросов

Макросы представляют собой серию команд, выполняющих определенные действия. Если команда, вызываемая макросом, принимает параметры, то нужно знать в какой последовательности. Каждый символ имеет значение - и даже пробел. Последовательность параметров может меняться от версии к версии AutoCAD. Когда команда вводится из пункта меню, значения системных переменных PICKADD и PICKAUTO равны 1 и 0 соответственно для совместимости с предыдущими версиями AutoCAD.

Таблица соответствия комбинация клавиш ascii-символам

При выполнении макросов AutoCAD помещает пробел в конец, перед выполнением последовательности команд. Когда это не желательно (например, для команд TEXT или DIM) команда может завершаться Enter, а не пробелом. Также иногда требуется более одного пробела или Enter, но некторые текстовые редакторы не позволяют создавать строки с концевыми пробелами. Для избежания этой проблемы используются два специальных соглашения:

Обратный слэш вызывает ввод параметров команды пользователем, и обычно после ввода одного параметра продолжается выполнение макроса. Значит невозможно создать макрос, принимающий переменное число параметров и продолжающего выполнение (как например при выборе объектов). Одно исключение сделано для команды SELECT. Например следующий макрос

select \change previous ;properties color red ;

позволяет выбрать несколько объектов, затем вызывается команда Change с опцией Previos и меняется цвет у выбранных объектов. Так как обратный слэш используется для ожидания ввода, его нельзя использовать для других действий. Поэтому при указании пути к файлу в качестве разделителя используется прямой слэш. Следующие обстоятельства задерживают выполнение макроса:

Перед началом выполнения макроса рекомендуется использовать последовательность ^C^C, чтобы отменить выполнение предыдущей команды. Для выполнения макроса в цикле используется *^C^C (при этом в самом макросе уже нельзя использовать ^C, т.к. это приведет к его прерыванию). Пример: *^C^CMOVE Single.

Добавление пунктов во всплывающее меню

Такие меню появляются когда пользователь нажимает правую кнопку мыши, удерживая при этом Shift. AutoCAD ищет высплывающее меню в группе меню по установленному значению свойства ShortcutMenu=TRUE. Добавление пункта во всплывающее меню

Sub AddMenuItemToshortcutMenu()
  Dim currMenuGroup As AcadMenuGroup
  Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)
  
  ' ищем всплывающее меню и назначаем ему переменную
  Dim scMenu As AcadPopupMenu
  Dim entry As AcadPopupMenu
  For Each entry In currMenuGroup.Menus
      If entry.shortcutMenu = True Then
          Set scMenu = entry
      End If
  Next entry
      
  ' добавим новый пункт меню
  Dim newMenuItem As AcadPopupMenuItem
  Dim openMacro As String
  openMacro = Chr(3) + Chr(3) + Chr(95) + "open" + Chr(32)
  
  Set newMenuItem = scMenu.AddMenuItem ("", Chr(Asc("")) + "OpenDWG", openMacro)
End Sub

Отслеживание событий

Существует три типа событий - уровня приложения, уровня документа и уровня объекта. События первого типа связаны с открытием, сохранением, закрытием и печатью документа, загрузкой-выгрузкой приложений, изменением системных переменных. События второго типа связаны с добавлением, удалением, изменением объектов, активацией меню, изменением размеров окна рисунка, регенерацией, открытием, закрытием, печатью чертежа и др. И события уровня объекта возникают только тогда, когда объект изменился.

Написание обработчиков событий

События дают информацию о состоянии или активности. Хотя обработчики событий написаны специально для того, чтобы отвечать на события, AutoCAD часто вмешивается в обработку событий. Следовательно, обработчики событий имеют ограничения для выполнения безопасных операций в союзе с AutoCAD и его базой данных. Не стоит надеяться на последовательность событий, т.к. они могут случиться в любом порядке, что следует учитывать в обработчике. К примеру, при вызове команды Open происходят события BeginCommand, BeginOpen, EndOpen и EndCommand, но случиться они могут в любом порядке, кроме пожалуй только события начала и события завершения. Не надейтесь также на последовательность операций (например, при удалении двух объектов не обязательно, что событие удаления объекта 1 будет после 2). Не пытайтесь применять в обработчиках любые интерактивные функции, например ввод от пользователя. Не запускайте диалоговые окна, можно только окна сообщений. Писать данные можно в любой объект базы чертежа, кроме того, который вызвал событие. Любой объект, вызвавший событие, остается открытым для AutoCADа, но запись в него может быть фатальной, читать же можно без ограничений. Не выполняйте в обработчике событий действий, которые вызывают подобный обработчик. (например открытие документа из обработчика события BeginOpen.

Обработчики событий уровня приложения

Данные события не становятся автоматически доступны при загрузке VBA, поэтому они должны быть разрешены вручную. После этого будут доступны следующие события:

Как разрешить события уровня приложения

Перед тем как начать использовать события уровня приложения следует создать новый модуль класса и объявить объект типа AcadApplication с применением ключевого слова WithEvents. Порядок работы следующий:

Public WithEvents App As AcadApplication

После того как новый объект объявлен с событиями он появится в окне списка объектов в модуле класса и можно выбирать процедуры событий для вновь созданного объекта из выпадающего списка. Однако перед тем как запустить процедуру нужно соединить объявленный объект с объектом Application, делается это с помощью такого кода в окне основного модуля:

Dim X As New EventClassModule

Sub InitializeEvents()
    Set X.App = ThisDrawing.Application
End Sub
' далее в коде основного модуля
Call InitializeEvents

После того как выполнится процедура InitializeEvents объект App модуля класса будет указывать на объект Приложение (Application) Пример перехвата процесса загрузки, когда файл методом Drag-And-Drop перенесен в окно AutoCAD, выводящее окно сообщения с именем файла

' * * * В модуле класса * * *
Option Explicit
Public WithEvents App As AcadApplication
Sub Example_AcadApplication_Events()
  ' Инициализируем глобальную переменную App
  ' которая будет использоваться для перехвата событий AcadApplication
  ' Обязательно запустить ее в начале
  Set App = GetObject(, "AutoCAD.Application")
End Sub

Private Sub App_BeginFileDrop(ByVal FileName As String, Cancel As Boolean)
 ' Пример перехвата события BeginFileDrop, каркас данной процедуры
 ' получен выбором из списка методов объекта App модуля класса в окне кода.
 ' Событие возникает как только файл перетащен в окно AutoCAD.
 '
 If MsgBox("AutoCAD загружает "  FileName  vbCrLf _
           "продолжить загрузку?", vbYesNoCancel + vbQuestion) <> vbYes Then
     Cancel = True
 End If
End Sub

' * * * В основной процедуре * * *
Option Explicit
Dim X As New EventClassModule
Sub InitializeEvents()
    Set X.App = ThisDrawing.Application
End Sub

Sub main()
Call InitializeEvents
End Sub

Обработка событий уровня документа

События уровня документа постоянно происходят в процессе работы AutoCADа. Это значит, что они автоматически делаются доступными при загрузке проекта VBA, однако не доступны, например, для VB. То есть для других ActiveX Automation приложений их надо разрешать вручную. Доступны следующие события:

Пример кодирования обработчиков событий уровня документа

Для этого нужно просто выбрать объект AutocadDocument из выпадающего меню в окне кода среды VBA IDE. Доступные события появятся в окне процедур, после выбора любой из них будет вставлен каркас процедуры обработки события. Данные процедуры будут касаться только активного документа. Пример обновления всплывающего меню при возникновении событий BeginShortcutMenuDefault и EndShortcutMenu путем добавления к нему пункта. Изменение не затрагивает файлы меню.

' это в модуле класса
Option Explicit
Public WithEvents mydoc As AcadDocument

Private Sub mydoc_BeginShortcutMenuDefault(ShortcutMenu As IAcadPopupMenu)
  On Error Resume Next
  ' Добавим пункт меню
  Dim newMenuItem As AcadPopupMenuItem
  Dim openMacro As String
  openMacro = Chr(27) + Chr(27) + Chr(95) + "open" + Chr(32)
  Set newMenuItem = ShortcutMenu.AddMenuItem(0, Chr(Asc("")) + "OpenDWG", openMacro)
End Sub

Private Sub mydoc_EndShortcutMenu(ShortcutMenu As IAcadPopupMenu)
  On Error Resume Next
  ShortcutMenu.Item("OpenDWG").Delete
End Sub

' это в основном модуле
Option Explicit
Dim X As New EventClass
Sub InitializeEvents()
    Set X.mydoc = ThisDrawing
End Sub
Sub main()
  Call InitializeEvents
End Sub

Обработка событий уровня объекта

События уровня объекта не доступны на момент загрузки VBA. После того как они сделаны доступны становится доступно событие Modified. Следующий пример создает полилинию с обработчиком события, который показывает новую площадь при изменении полилинии.

' в модуле класса с именем EventClass
Option Explicit
Public WithEvents Object As AcadCircle

Private Sub Object_Modified(ByVal pObject As IAcadObject)
On Error GoTo errmsg
MsgBox "Площадь "  pObject.ObjectName  " "  pObject.Area
Exit Sub
errmsg:
MsgBox Err.Description
End Sub

' В основой программе
Dim X As New EventClass
Sub main()
Call InitializeEvents
End Sub

Sub InitializeEvents()
   Dim MyCircle As AcadCircle
   Dim centerPoint(0 To 2) As Double
   Dim radius As Double
   centerPoint(0) = 0#: centerPoint(1) = 0#: centerPoint(2) = 0#: radius = 5#
   Set MyCircle = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)
   Set X.Object = MyCircle
   ZoomExtents
End Sub

Работа с трехмерными поверхностями

Для указания трехмерных координат кроме координат по осям X и Y вводится еще и координата по оси Z в мировой или заданной пользоавтелем системе координат. Положение оси Z определяется правилом правой руки. Пример вычерчивания в 3D.

Sub Polyline_2D_3D()
  Dim pline2DObj As AcadLWPolyline
  Dim pline3DObj As AcadPolyline

  Dim points2D(0 To 5) As Double
  Dim points3D(0 To 8) As Double

' Зададим три точки 2D-полилинии
  points2D(0) = 1: points2D(1) = 1
  points2D(2) = 1: points2D(3) = 2
  points2D(4) = 2: points2D(5) = 2

' Зададим три точки 3D-полилинии
  points3D(0) = 1: points3D(1) = 1: points3D(2) = 0
  points3D(3) = 2: points3D(4) = 1: points3D(5) = 0
  points3D(6) = 2: points3D(7) = 2: points3D(8) = 0

Set pline2DObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points2D)
pline2DObj.Color = acRed
pline2DObj.Update

Set pline3DObj = ThisDrawing.ModelSpace.AddPolyline(points3D)
pline3DObj.Color = acBlue
pline3DObj.Update

' Прочитаем координаты полилиний
Dim get2Dpts As Variant,get3Dpts As Variant
get2Dpts = pline2DObj.Coordinates
get3Dpts = pline3DObj.Coordinates

MsgBox ("2D полилиния (красная): "  vbCrLf  _
   get2Dpts(0)  ", "  get2Dpts(1)  vbCrLf  _
   get2Dpts(2)  ", "  get2Dpts(3)  vbCrLf  _
   get2Dpts(4)  ", "  get2Dpts(5))

MsgBox ("3D полилиния (синяя): "  vbCrLf  _
   get3Dpts(0)  ", "  get3Dpts(1)  ", "  _
   get3Dpts(2)  vbCrLf  _
   get3Dpts(3)  ", "  get3Dpts(4)  ", "  _
   get3Dpts(5)  vbCrLf  _
   get3Dpts(6)  ", "  get3Dpts(7)  ", "  _
   get3Dpts(8))
End Sub

Определение пользовательской системы координат

Часто бывает нужно сменить положение начальной точки отсчета системы координат и ориентацию осей, особенно при работе с трехмерными моделями. При этом системы координат пространства листа ограничены плоскостью. Метод Add, позволяющий создать новую систему координат требует на входе четыре параметра: координаты начала, координаты осей X Y и название ПСК. (пользоавтельской системы координат). Все координаты вводятся в мировой системе. Метод GetUCSMatrix используется для преобразования систем координат. Чтобы сделать систему координат активной используется свойство объекта Document.ActiveUCS. Если изменения делаются в активной системе координат, то требуется повторная установка свойства ActiveUCS. Пример создания системы координат, установки ее активной и трансляции координат точек в новую систему координат.

Sub NewUCS()
  Dim ucsObj As AcadUCS
  Dim origin(0 To 2) As Double
  Dim xAxisPnt(0 To 2) As Double
  Dim yAxisPnt(0 To 2) As Double
  ' Зададим точки ПСК
  origin(0) = 4: origin(1) = 5: origin(2) = 3
  xAxisPnt(0) = 5: xAxisPnt(1) = 5: xAxisPnt(2) = 3
  yAxisPnt(0) = 4: yAxisPnt(1) = 6: yAxisPnt(2) = 3

  ' Добавим в ПСК в коллекцию UserCoordinatesSystems
  Set ucsObj = ThisDrawing.UserCoordinateSystems. _
           Add(origin, xAxisPnt, yAxisPnt, "New_UCS")
  ' Отобразим значек ПСК
  ThisDrawing.ActiveViewport.UCSIconAtOrigin = True
  ThisDrawing.ActiveViewport.UCSIconOn = True

  ' Сделаем активной
  ThisDrawing.ActiveUCS = ucsObj
  MsgBox "Текущая ПСК : "  ThisDrawing.ActiveUCS.Name  vbCrLf  " Выбери точку."

  ' Найти ПСК и МСК - координаты точки
  Dim WCSPnt As Variant,UCSPnt As Variant

  WCSPnt = ThisDrawing.Utility.GetPoint(, "Введи точку: ")
  UCSPnt = ThisDrawing.Utility.TranslateCoordinates(WCSPnt, acWorld, acUCS, False)

  MsgBox "Коорд. МСК: "  WCSPnt(0)  ", "  WCSPnt(1)  ", "  WCSPnt(2)  vbCrLf  _
        "Коорд. ПСК: "  UCSPnt(0)  ", "  UCSPnt(1)  ", "  UCSPnt(2)
End Sub

Преобразования координат

Метод TranslateCoordinates преобразует координаты точек из одной системы в другую. Параметр OriginalPoint может рассматриваться как 3D точка так и 3D вектор. Этот аргумент различается в зависимости от значения аргумента Disp, если последний равен TRUE, значит OriginalPoint рассматривается как вектор. Еще два аргумента определяют из какой системы в какую преобразовывать. В качестве их значений могут быть WCS - мировая система (все остальные задаются относительно нее), UCS - рабочая система (все координаты задаются относительно нее), OCS - система координат объекта, DCS - система координат дисплея, PSDCS - система координат пространства листа. Пример преобразования OCS в WCS

Sub TranslateCoordinates()
  Dim plineObj As AcadPolyline
  Dim points(0 To 14) As Double

  points(0) = 1: points(1) = 1: points(2) = 0
  points(3) = 1: points(4) = 2: points(5) = 0
  points(6) = 2: points(7) = 2: points(8) = 0
  points(9) = 3: points(10) = 2: points(11) = 0
  points(12) = 4: points(13) = 4: points(14) = 0

  Set plineObj = ThisDrawing.ModelSpace.AddPolyline(points)

  ' Найдем X и Y координаты первой вершины полилинии
  Dim firstVertex As Variant
  firstVertex = plineObj.Coordinate(0)

  ' Найдем Z-координату полилинии, через свойство elevation
  firstVertex(2) = plineObj.Elevation

  Dim plineNormal(0 To 2) As Double
  plineNormal(0) = 0#: plineNormal(1) = 1#: plineNormal(2) = 2#
  plineObj.Normal = plineNormal

  ' Переведем из OCS в WCS
  Dim coordinateWCS As Variant
  coordinateWCS = ThisDrawing.Utility.TranslateCoordinates _
        (firstVertex, acOCS, acWorld, False, plineNormal)

  MsgBox "Координаты первой вершины полилинии:" _
          vbCrLf  "OCS: "  firstVertex(0)  ", "  _
         firstVertex(1)  ", "  firstVertex(2)  vbCrLf  _
         "WCS: "  coordinateWCS(0)  ", "  _
         coordinateWCS(1)  ", "  coordinateWCS(2)
End Sub

Создание 3-мерных объектов

AutoCAD поддерживает три типа трехмерных объектов: каркасная рамка, поверхность и сплошной, каждый из типов обладает своими методами создания и редактирования. Каркасная рамка представляет собой скелетное описание трехмерного объекта и состоит только из точек, линий, кривых, описывающих грани объекта. Второй тип более сложен, т.к. описывает еще и поверхность, а третий наиболее простой способ рисования реальных объектов. При этом используется базовый набор - куб, конус, цилиндр, сфера, клин и тор. Сложные объекты можно получить путем объединения, вычитания и пересечения. Еще способ получить трехмерный объект заключается во вращении плоского вокруг оси.

Создание каркасных рамок

Для этого достаточно разместить любой плоский объект в трехмерном пространстве одним из следующих методов: указав при создании объекта три координаты, заданием плоскости построения, перемещением объекта в другую плоскость. Метод Add3DPoly создает трехмерную полилинию.

Создание сеток

Сетки можно создавать как в 2D так и в 3D, но используются они приимущественно в трехмерных построениях. Нужны в тех случаях когда нет необходимости детального просмотра объекта, бывают разомкнутыми и замкнутыми. Создаются с использованием метода Add3DMesh, который на входе требует три параметра: Число вершин в направлении M, число вершин в направлении N, и массив типа Variant с координатами всех вершин. Как только создана PolygonMesh через свойства MClose и NClose можно делать сетку замкнутой. Пример создания сетки 4х4

Sub Create3DMesh()
  Dim meshObj As AcadPolygonMesh
  Dim mSize, nSize, Count As Integer
  Dim points(0 To 47) As Double

  ' координаты вершин сетки
  points(0) = 0: points(1) = 0: points(2) = 0
  points(3) = 2: points(4) = 0: points(5) = 1
  points(6) = 4: points(7) = 0: points(8) = 0
  points(9) = 6: points(10) = 0: points(11) = 1
  points(12) = 0: points(13) = 2: points(14) = 0
  points(15) = 2: points(16) = 2: points(17) = 1
  points(18) = 4: points(19) = 2: points(20) = 0
  points(21) = 6: points(22) = 2: points(23) = 1
  points(24) = 0: points(25) = 4: points(26) = 0
  points(27) = 2: points(28) = 4: points(29) = 1
  points(30) = 4: points(31) = 4: points(32) = 0
  points(33) = 6: points(34) = 4: points(35) = 0
  points(36) = 0: points(37) = 6: points(38) = 0
  points(39) = 2: points(40) = 6: points(41) = 1
  points(42) = 4: points(43) = 6: points(44) = 0
  points(45) = 6: points(46) = 6: points(47) = 0

  mSize = 4: nSize = 4

  Set meshObj = ThisDrawing.ModelSpace.Add3DMesh(mSize, nSize, points)

  ' Изменим направление взгляда, чтоб лучше видеть
  Dim NewDirection(0 To 2) As Double
  NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1
  ThisDrawing.ActiveViewport.direction = NewDirection
  ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
  ZoomAll
End Sub

Создание polyface сетки

Используя метод AddPolyfaceMesh можно создавать сетку каждая грань которой может состоять из нескольких вершин. Каждой грани можно назначить свой цвет или сделать ее невидимой, если задать отрицательное значение номеров вершин. Пример создания:

Sub CreatePolyfaceMesh()
  Dim vertex(0 To 17) As Double
  vertex(0) = 4: vertex(1) = 7: vertex(2) = 0
  vertex(3) = 5: vertex(4) = 7: vertex(5) = 0
  vertex(6) = 6: vertex(7) = 7: vertex(8) = 0
  vertex(9) = 4: vertex(10) = 6: vertex(11) = 0
  vertex(12) = 5: vertex(13) = 6: vertex(14) = 0
  vertex(15) = 6: vertex(16) = 6: vertex(17) = 1

  Dim FaceList(0 To 7) As Integer
  FaceList(0) = 1: FaceList(1) = 2
  FaceList(2) = 5: FaceList(3) = 4
  FaceList(4) = 2: FaceList(5) = 3
  FaceList(6) = 6: FaceList(7) = 5

  Dim polyfaceMeshObj As AcadPolyfaceMesh
  Set polyfaceMeshObj = ThisDrawing.ModelSpace.AddPolyfaceMesh(vertex, FaceList)
  ' Чтоб лучше было видно сменим обзор
  Dim NewDirection(0 To 2) As Double
  NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1
  ThisDrawing.ActiveViewport.direction = NewDirection
  ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
  ZoomAll
End Sub

Создание сплошных 3d объектов

Сплошные трехмерные объекты AutoCAD дают наиболее полное предстваление о реальном объекте. Для их создания используются следующие методы: AddBox, AddCone, AddCylinder, AddEllipticalCone, AddEllipticalCylinder, AddExtrudedSolid, AddExtrudedSolidAlongPath, AddRevolvedSolid, AddSolid, AddSphere, AddTorus, AddWedge.

Пример:

Sub CreateWedge()
  Dim wedgeObj As Acad3DSolid
  Dim center(0 To 2) As Double
  Dim length As Double
  Dim width As Double
  Dim height As Double

  center(0) = 5#: center(1) = 5#: center(2) = 0
  length = 10#: width = 15#: height = 20#

  Set wedgeObj = ThisDrawing.ModelSpace.AddWedge(center, length, width, height)

  Dim NewDirection(0 To 2) As Double
  NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1
  ThisDrawing.ActiveViewport.direction = NewDirection
  ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
  ZoomAll
End Sub

Редактирование в трех измерениях

Для вращения трехмерных объектов используется метод Rotate или Rotate3D. Пример:

Sub Rotate_3DBox()
  Dim boxObj As Acad3DSolid
  Dim length As Double
  Dim width As Double
  Dim height As Double
  Dim center(0 To 2) As Double

  center(0) = 5: center(1) = 5: center(2) = 0
  length = 5: width = 7: height = 10
  Set boxObj = ThisDrawing.ModelSpace.AddBox(center, length, width, height)

  ' Определим оси вращения по двум точкам
  Dim rotatePt1(0 To 2) As Double,rotatePt2(0 To 2) As Double
  Dim rotateAngle As Double
  rotatePt1(0) = -3: rotatePt1(1) = 4: rotatePt1(2) = 0
  rotatePt2(0) = -3: rotatePt2(1) = -4: rotatePt2(2) = 0
  rotateAngle = 30
  rotateAngle = rotateAngle * 3.141592 / 180#
  ' Собственно вращение
  boxObj.Rotate3D rotatePt1, rotatePt2, rotateAngle
  ZoomAll
End Sub

Массивы трехмерных объектов

Используя метод ArrayRectangular можно задавать массивы трехмерных объектов с распространением их в любом направлении, то есть не только по числу строк и стролбцов, но и по числу уровней (ось Z). Пример:

Sub CreateRectangularArray()
  Dim circleObj As AcadCircle
  Dim center(0 To 2) As Double
  Dim radius As Double
  center(0) = 2: center(1) = 2: center(2) = 0: radius = 0.5
  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)

  ' зададим прямоугольный массив
  Dim numberOfRows As Long,numberOfColumns As Long,numberOfLevels As Long
  Dim distBwtnRows As Double,distBwtnColumns As Double,distBwtnLevels As Double
  numberOfRows = 4: numberOfColumns = 4: numberOfLevels = 3
  distBwtnRows = 1: distBwtnColumns = 1: distBwtnLevels = 4

  ' создадим маасив объектов
  Dim retObj As Variant
  retObj = circleObj.ArrayRectangular _
      (numberOfRows, numberOfColumns, _
       numberOfLevels, distBwtnRows, _
       distBwtnColumns, distBwtnLevels)
  ZoomAll
End Sub

Отражение в 3d

Sub MirrorABox3D()
  ' создадим коробок
  Dim boxObj As Acad3DSolid
  Dim length As Double,width As Double,height As Double
  Dim center(0 To 2) As Double
  center(0) = 5#: center(1) = 5#: center(2) = 0
  length = 5#: width = 7: height = 10#

  Set boxObj = ThisDrawing.ModelSpace.AddBox(center, length, width, height)

  ' Определим плоскость отражения тремя точками
  Dim mirrPt1(0 To 2) As Double,mirrPt2(0 To 2) As Double,mirrPt3(0 To 2) As Double

  mirrPt1(0) = 1.25: mirrPt1(1) = 0: mirrPt1(2) = 0
  mirrPt2(0) = 1.25: mirrPt2(1) = 2: mirrPt2(2) = 0
  mirrPt3(0) = 1.25: mirrPt3(1) = 2: mirrPt3(2) = 2

  ' отразим
  Dim mirrorBoxObj As Acad3DSolid
  Set mirrorBoxObj = boxObj.Mirror3D(mirrPt1, mirrPt2, mirrPt3)
  mirrorBoxObj.Color = acRed
  ZoomAll
End Sub

Редактирование трехмерных тел

Пример построения коробки и цилиндра для которых находится пересечение и на основании последнего строится новая фигура. Для большей наглядности все объекты рисуются разным цветом.

Sub FindInterferenceBetweenSolids()
  Dim boxObj As Acad3DSolid
  Dim length As Double,width As Double,height As Double
  Dim center(0 To 2) As Double
  center(0) = 5: center(1) = 5: center(2) = 0
  length = 5: width = 7: height = 10

  Set boxObj = ThisDrawing.ModelSpace.AddBox(center, length, width, height)
  boxObj.Color = acWhite

  ' теперь цилиндр
  Dim CylObj As Acad3DSolid
  Dim CylRadius As Double
  Dim CylHeight As Double
  center(0) = 0: center(1) = 0: center(2) = 0
  CylRadius = 5: CylHeight = 20

  Set CylObj = ThisDrawing.ModelSpace.AddCylinder(center, CylRadius, CylHeight)
  CylObj.Color = acCyan

  ' Найдем пересечение
  Dim solidObj As Acad3DSolid
  Set solidObj = boxObj.CheckInterference(CylObj, True)
  solidObj.Color = acRed
  ZoomExtents
End Sub

Использование метода SectionSolid помогает найти пересечение двух сплошных тел, а метод SliceSolid разрезать тело на два новых. Пример такой нарезки:

Sub SliceABox()
  Dim boxObj As Acad3DSolid
  Dim length As Double,width As Double,height As Double
  Dim center(0 To 2) As Double
  center(0) = 5#: center(1) = 5#: center(2) = 0
  length = 5#: width = 7: height = 10#

  Set boxObj = ThisDrawing.ModelSpace.AddBox(center, length, width, height)
  boxObj.Color = acWhite

  ' Зададим секущую плоскость тремя точками
  Dim slicePt1(0 To 2) As Double
  Dim slicePt2(0 To 2) As Double
  Dim slicePt3(0 To 2) As Double

  slicePt1(0) = 1.5: slicePt1(1) = 7.5: slicePt1(2) = 0
  slicePt2(0) = 1.5: slicePt2(1) = 7.5: slicePt2(2) = 10
  slicePt3(0) = 8.5: slicePt3(1) = 2.5: slicePt3(2) = 10

  ' рассечем коробочку плоскотью и закрасим другим цветом
  Dim sliceObj As Acad3DSolid
  Set sliceObj = boxObj.SliceSolid(slicePt1, slicePt2, slicePt3, True)
  sliceObj.Color = acRed
  ZoomExtents
End Sub

Подобно сеткам сплошные тела отображаются как каркасная рамка, до тех пор пока их не скроешь, затенишь или отрендеришь. Кроме того сплошные тела можно анализировать на предмет объема, момента инерции, центра тяжести и т.д. Для чего используются следующие свойства MomentOfInertia, PrincipalDirections, PrincipalMoments, ProductOfInertia, RadiiOfGyration, и Volume. Свойство ContourlinesPerSurface управляет числом линий используемых для отображения каркасной рамки. Свойство RenderSmoothness регулирует плавность прорисовки фигуры.

Вычерчивание и настройка разметки (layouts)

Понятие пространства модели и пространства листа: в пространстве модели обычно вычерчивают в реальных мировых единицах. Пространство листа представляет модель в том виде в котором она выходит на печать. В пространстве листа можно настраивать различные видовые экраны и показывать модель или ее детали в произволном масштабе. Для одного чертежа может существовать много пространств листов.

Вся геометрия рисунка содержится в макетах. Геометрия пространства модели содержится на одном макете называемом Model. Его нельзя переименовать, но можно создать еще один. В одном рисунке может быть только одно пространство модели.Геометрия пространства листа также содержится на макетах. Может быть много различных макетов пространства листа, каждый из которых представляет свою конфигурацию для печати. В ActiveX-автоматизации объект ModelSpace содержит всю геометрию макета пространства модели. А т.к. пространств листов много, то объект PaperSpace указывает на последний активный.

Содержимое любого макета распределено между двумя различными объектами ActiveX Layout и Block. Объект Layout содержит настройки печати и визуальные свойства появляющиеся в интерфейсе пользователя. Объект Block содержит геометрию макета. Каждый объект Layout ассоциируется только с одним объектом Block. Для доступа к объекту используется свойство Block, а для доступа из блока к Layout используется соответствующее свойство блока. Объект PlotConfiguration подобен объекту Layout отличаясь тем, что не имеет связи с конкретным объектом Block, а является именованной коллекцией настроек плоттера.

Настройки макета управляют окончательной печатью. Они затрагивают - размер бумаги, масштаб вычерчивания, область вычерчивания, начало координат вычерчивания и устройство печати. Все настройки Layout доступны через его свойства и методы.

Для выбора размера бумаги и единиц следует обращаться к каноническому имени принтера, можно также указать единицы используя свойство PaperUnits, которое принимает одно из трех значений: acInches, acMillimeters, acPixels. Для установки начала координат плоттера есть свойство CenterPlot, (по умолчанию оно равно FALSE)

Чтобы задать область вычерчивания есть свойство PlotType, которое может принимать одно из следующих значений: acDisplay - печатать все содержимое пространства модели (недоступно при печати из пространства листа), acExtents - печатать все что находится внутри границ, acLimits - печатать все внутри пределов, acView - печатать видовой экран заданный ViewToPlot, acWindow - печатать содержимое выбранного методом SetWindowToPlot окна, acLayout - печатать содержимое в границах пространства листа (недоступно при печати из пространства модели).

Чтобы задать масштаб вычерчивания есть два метода - стандартный масштаб установив свойство UseStandardScale в значение TRUE, после чего задать значение свойства StandardScale. Более гибкий метод - ввод пользовательского масштаба через UseStandardScale = FALSE и далее методом SetCustomScale указываем нужный масштаб. Можно также использовать значение acScaleToFit свойства StandardScale для подгонки изображения под размер листа. Для управления масштабированием веса линий свойство ScaleLineweights следует установить = TRUE.

Имя устройства печати задается свойством ConfigName, если его не трогать то печать будет идти на устройство по-умолчанию.

Видовые экраны

Для одновременного отображения нескольких частей рисунка, в т.ч. в разных масштабах существуют видовые экраны (ViewPorts). Они могут быть как "впритык" друг к другу, так и плавающими. Рисовать примечания можно непосредственно в пространстве листа не затрагивая пространства модели. Нельзя редактировать модель из пространства листа. Для доступа к модели в объекте PViewport следует переключиться из пространства листа в пространство модели через свойство ActiveSpace. При работе в PViewport объекте возможности редактирования почти такие же как и в Viewport, однако, в первом случае более удобна работа с отдельными видами. К примеру, можно заморозить или отключить слои на некоторых видовых экранах, не затрагивая остальные. Можно включить и выключить весь видовой экран. Можно так же выравнивать виды по видовым экранам. При работе с объектом ViewPort свойство ActiveSpace должно быть установлено в acModelSpace. При работе с объектом PViewport свойство ActiveSpace можно установить как в значение acModelSpace так и в acPaperSpace, то есть переключаться по мере необходимости.

Свойство ActiveSpace меняет значение системной переменной TILEMODE. Установка ThisDrawing.ActiveSpace = acModelSpace эквивалентна TILEMODE = on, и установка ThisDrawing.ActiveSpace = acPaperSpace эквивалентна TILEMODE = off. Так же свойство MSpace является эквивалентом команд MSpace и PSpace. Установка ThisDrawing.MSpace = TRUE - то же самое, что использование команды MSPACE, а установка ThisDrawing.MSpace = FALSE эквивалентна команде PSPACE то есть переключает в пространство листа. В дополнение к сказанному требуется использование метода Display перед установкой свойства MSpace = TRUE, т.к. он инициализирует определенные графические установки, которые должны быть установлены перед переключением в пространство модели. Однако в ActiveX автоматизации установку этих настроек возлагают на программиста. Запомните: следует включить display методом Display по крайней мере для одного объекта PViewport перед тем как устанавливать свойств MSpace = TRUE

Переключение в лэйауты пространства листа

Переключиться из пространства модели в последний активный лэйаут пространства листа можно так:

ThisDrawing.ActiveSpace = acPaperSpace2. ThisDrawing.MSpace = FALSE.

Когда вы находитесь в пространстве листа AutoCAD отображает иконку ПСК в нижнем левом углу графической области. Перекрестие указывает, что область пространства листа может быть редактирована. (не виды в видовых экранах)

Переключение в пространство модели

Из пространства листа можно переключаться в плавающие или закрепленные стык в стык видовые экраны пространства модели. Для переключения в плавающий видовой экран инициализируем дисплей ThisDrawing.ActivePViewport.Display=TRUE и переключаемся ThisDrawing.MSpace = TRUE. Для переключения к состыкованным видовым экранам нужно выполнить дополнительный шаг ThisDrawing.MSpace = TRUE

Создание видовых экранов пространства листа

Видовые экраны пространства листа создаются методом AddPViewport. Метод требует указания центральной точки, а также ширины и высоты. Перед применением метода следует установить пространство листа текущим, обычно TILEMODE = 0. После создания объекта PViewport можно устанавливать свойства Direction, LensLength, GridOn, Layer, Linetype, LinetypeScale. Пример переключений между пространствами и создания плавающего видового экрана:

Sub SwitchToPaperSpace()
    ' Установка активным пространства листа
    ThisDrawing.ActiveSpace = acPaperSpace

    ' Создание видового экрана листа
    Dim newVport As AcadPViewport
    Dim center(0 To 2) As Double
    center(0) = 3.25 : center(1) = 3 : center(2) = 0
    Set newVport = ThisDrawing.PaperSpace.AddPViewport(center, 6, 5)

    ' Изменим направление вида
    Dim viewDir(0 To 2) As Double
    viewDir(0) = 1 : viewDir(1) = 1 : viewDir(2) = 1
    newVport.direction = viewDir

    ' Включим видовой экран
    newVport.Display True

    ' Обратно в пространство модели
    ThisDrawing.MSpace = True

    ' Сделаем вид активным
    ' (не всегда нужно, но неплохая идея)
    ThisDrawing.ActivePViewport = newVport

    ZoomExtents

    ' Отключим редактирование
    ThisDrawing.MSpace = False

    ' ZoomExtents в пространстве листа
    ZoomExtents
End Sub

Порядок шагов в вышеприведенном коде очень важен! Для того чтобы менять значения свойств объекта Viewport метод Display должен ьыть отключен, а перед тем как делать видовой экран текущим, метод Display нужно включить. Пример создания плавающего видового экрана использует предыдущий пример и устанавливает для четырех видовых экранов вид сверху, спереди, справа и изометрический соответствующим образом. Чтобы увидеть результаты следует создать сферу 3DSolid.

Sub FourPViewports()
    Dim topVport, frontVport As AcadPViewport
    Dim rightVport, isoVport As AcadPViewport
    Dim pt(0 To 2) As Double
    Dim viewDir(0 To 2) As Double
    ThisDrawing.ActiveSpace = acPaperSpace
    ThisDrawing.MSpace = True
' Возьмем существующий PViewport и сделаем его topVport
    pt(0) = 2.5: pt(1) = 5.5: pt(2) = 0
    Set topVport = ThisDrawing.ActivePViewport
' Нет необходимости указывать направление для вида с верху
    topVport.center = pt
    topVport.width = 2.5
    topVport.height = 2.5
    topVport.Display True
    ThisDrawing.MSpace = True
    ThisDrawing.ActivePViewport = topVport
    ZoomExtents
    ZoomScaled 0.5, acZoomScaledRelativePSpace
' Создадим и настроим фронтальный вид frontVport
    pt(0) = 2.5: pt(1) = 2.5: pt(2) = 0
    Set frontVport = ThisDrawing.PaperSpace.AddPViewport(pt, 2.5, 2.5)
    viewDir(0) = 0: viewDir(1) = 1: viewDir(2) = 0
    frontVport.direction = viewDir
    frontVport.Display acOn
    ThisDrawing.MSpace = True
    ThisDrawing.ActivePViewport = frontVport
    ZoomExtents
    ZoomScaled 0.5, acZoomScaledRelativePSpace
' А теперь вид с права rightVport
    pt(0) = 5.5: pt(1) = 5.5: pt(2) = 0
    Set rightVport = ThisDrawing.PaperSpace.AddPViewport(pt, 2.5, 2.5)
    viewDir(0) = 1: viewDir(1) = 0: viewDir(2) = 0
    rightVport.direction = viewDir
    rightVport.Display acOn
    ThisDrawing.MSpace = True
    ThisDrawing.ActivePViewport = rightVport
    ZoomExtents
    ZoomScaled 0.5, acZoomScaledRelativePSpace
' И наконец изометрический isoVport
    pt(0) = 5.5: pt(1) = 2.5: pt(2) = 0
    Set isoVport = ThisDrawing.PaperSpace.AddPViewport(pt, 2.5, 2.5)
    viewDir(0) = 1: viewDir(1) = 1: viewDir(2) = 1
    isoVport.direction = viewDir
    isoVport.Display acOn
    ThisDrawing.MSpace = True
    ThisDrawing.ActivePViewport = isoVport
    ZoomExtents
    ZoomScaled 0.5, acZoomScaledRelativePSpace
    ThisDrawing.Regen True
End Sub

Изменение вида и содержимого видовых экранов

Чтобы изменить вид объекта ViewPort надо находиться в пространстве модели и видовой экран должен быть активен. Для редактирования в плавающем видовом экране в пространстве модели сделайте видовой экран активным установкой свойства ActiveViewport следующим образом Thisdrawing.ActiveViewport = MyViewportObject и редактируйте. Можно также создавать объекты такие как примечания, размерности и др. в пространстве листа. Однако для этого следует установить ActiveSpace в состояние FALSE и включить пространство листа через свойство MSpace. Объекты, создаваемые в пространстве листа, только там и видны.

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

Перед печатью можно подобрать точный масштаб для каждой секции чертежа, (видового экрана). Масштабирование видов относительно пространства листа основывается на последовательном изменении масштаба каждого видового экрана. При работе в пространстве листа масштаб представляет собой отношение размера листа к реальному размеру вычерчиваемого объекта, отображаемого в видовых экранах. Метод ZoomScaled, масштабирует видовые экраны относительно пространства листа. Он принимает три параметра: видовой экран, фактор масштабирования, и тип масштабирования. Третий параметр необязателен, он позволяет выбрать масштабирование относительно границ рисунка, относительно текущего вида, относительно единиц пространства листа (acZoomScaledRelativePSpace). Дробные значения фактора масштаба уменьшают изображение.

Масштабирование образцов типов линий в пространстве листа

В пространстве листа любой тип линий может масштабироваться двумя путями:

Системная переменная PSLTSCALE позволяет содержать различные масштабы типов линий для объектов отображаемых в различных масштабах и в разных видовых экранах. Это так же затрагивает линии в 3D-видах.

Скрытие линий в видовых экранах

Если чертеж содежит трехмерные объекты, то можно убрать скрытые линии с заданного видового экрана перед тем как выводить на печать. Для этого используется свойство RemoveHiddenLines для заданного видового экрана, которое принимает значение TRUE или FALSE. Для отмены вывода на печать скрытых линий видовых экранов пространства модели есть свойство PlotHidden объекта Layout.

Печать чертежей

Печатать чертеж можно в том виде, в котором он представлен в пространстве модели или в виде, подготовленном для печати через пространство листа. Печать из пространства модели часто предпочтительна, когда нужно распечатать черновик для предварительного просмотра-проверки. Когда же модель готова можно печатать из пространства листа. Печать задействует два объекта ActiveX Layout и Plot. Первый содержит настройки печати для данного лэйаута, второй методы и свойства для запуска и отслеживания процесса печати.

Выполнение базовых операций

Объектом Plot обладает следующими свойствами и методами: PlotToFile, PlotToDevice, DisplayPlotPreview, SetLayoutsToPlot, StartBatchMode, QuietErrorMode, NumberOfCopies, BatchPlotProgress (получить состояние или прервать печать). Метод SetLayoutsToPlot, следует вызывать перед каждым методом PlotToDevice и PlotToFile. В противном случае будет печататься активный лэйаут. Если свойство NumberOfCopies не переустановлено, то будет использовано значение от предыдущего задания. Перед началом пакетной печати установите QuietErrorMode=TRUE, чтобы печать шла непрерывно. Далее метод StartBatchMode начинает печать.

Печать из пространства модели

Обычно при печати больших чертежей указывается масштаб преобразования из единиц вычерчивания в единицы печати. Однако при печати из пространства модели используются следующие умолчания: печать на системный принтер текущего дисплея, масштабируется так чтобы полностью уместилось вращение 0 и смещение 0, 0. Для изменения умолчаний - измените свойство объекта Layout ассоциированного с пространством модели. Пример печати границ активного лэйаута.

Sub PrintModelSpace()
    ' Проверим что активно пространство модели
    If ThisDrawing.ActiveSpace = acPaperSpace Then
        ThisDrawing.MSpace = True
        ThisDrawing.ActiveSpace = acModelSpace
    End If
    
    ' Зададим границы и масштаб печатаемой области.
    ThisDrawing.ModelSpace.Layout.PlotType = acExtents
    ThisDrawing.ModelSpace.Layout.StandardScale = acScaleToFit
    
    ' И число копий
    ThisDrawing.Plot.NumberOfCopies = 1
    
    ' Запустим печать
    ThisDrawing.Plot.PlotToDevice
End Sub

Имя устройства печати задается с помощью ConfigName, но может быть переопределено методом PlotToDevice с указанием файла PC3.

Печать из пространства листа

В любой момент времени можно распечатать сразу несколько лэйаутов, указав их имя. Пример печати двух таких на плотере по умолчанию:

Sub PrintPaperSpace()
    ' Установим лэйауты пространства листа которые будем печатать
    Dim strLayouts(0 To 1) As String
    Dim varLayouts As Variant
    strLayouts(0) = "Layout1"
    strLayouts(1) = "Layout2"
    varLayouts = strLayouts
    ThisDrawing.Plot.SetLayoutsToPlot varLayouts
    ' Число копий
    ThisDrawing.Plot.NumberOfCopies = 1
    ' Печать
    ThisDrawing.Plot.PlotToDevice
End Sub

Продвинутые приемы вычерчивания. Работа с растровыми изображениями

Есть достаточно причин для того чтобы комбинировать растровые и векторные изображения в одном рисунке, это могут быть космические снимки, отсканированные чертежи и т.д. Растровые изображения можно представить в виде решетки, каждый элемент которой называют пискелем. Растры могут быть скопированы, перемещены, обрезаны по прямоугольнику или полигону. Некотрые из поддерживаемых форматов могут отображать прозрачные пиксели. Растры могут быть монохромными, 8-бит градации серого, 8-бит цветные и 24-бит цветные. Тип файла Autocad определяет не по его расширению, а по содержимому.

Тип растрового изображения       расширение

BMP      Windows и OS/2         обычно .bmp, .dib, .rle
CALS-I   Mil-R-Raster I         .gp4, .mil, .rst, .cg4, .cal
GeoSPOT  GeoSPOT                .bil
IG4      Image System Group 4   .ig4
IGS      Image System Grayscal  .igs
JPEG     Joint Photogr. Expert  .jpg
FLIC     FLIC Autodesk Animator .flc, .fli
PCX      Picture PC Paintbrush  .pcx
PICT     Picture Macintosh      .pct
PNG      Portable Network Grapf .png
RLC      Run Length Compresson  .rlc
TARGA    True Vision Raster     .tga
TIF      Tagged Image Format    .tif

Присоединение и масштабирование растрового изображения

Растры вставленные в рисунок Autocadа на самом деле не являются его частью, а только ссылкой, и не сильно увеличивают размер файла. Добавление растра выполняется методом AddRaster который на входе принимает 4 параметра: имя растра, точку вставки, фактор масштабирования и вращения. После присоединения растра его можно в любое время отсоединить. Каждый из них обладает собственной границей обрезки, яркостью, контрастностью и прозрачностью. Фактор масштабирования можно задать при создании растрового объекта, чтобы его единицы измерения совпадали с остальными. Если вставлять растр, то его фактор масштабирования по-умолчанию = 1 в единицах вычерчивания. Чтоб задать реальный масштаб, нужно знать размеры изображения, при этом очень удобно, когда в самой картинке хранятся данные о числе точек (пикселей) на дюйм DPI и размеры в пикселях. Если это так, например, картинка сканировалась в 1 дюйме 50 футов, то есть 1:600, и единицы вычерчивания в Autocad дюймы, то фактор масштабирования будет 600. Пример вставки растра:

Sub AttachingARaster()
    Dim insertionPoint(0 To 2) As Double
    Dim scalefactor As Double
    Dim rotationAngle As Double
    Dim imageName As String
    Dim rasterObj As AcadRasterImage
    imageName = "C:/Acad2000/sample/watch.jpg"
    insertionPoint(0) = 5: insertionPoint(1) = 5: insertionPoint(2) = 0
    scalefactor = 2: rotationAngle = 0

    On Error GoTo ERRORHANDLER
    ' Вставить растр в пространство модели
    Set rasterObj = ThisDrawing.ModelSpace.AddRaster(imageName, _
        insertionPoint, scalefactor, rotationAngle)
    ZoomExtents
    Exit Sub
ERRORHANDLER:
    MsgBox Err.Description
End Sub

Управление растровыми изображениями

Для того чтобы сменить путь к файлу изображения достаточно изменить значение свойства ImageFile, если Autocad не может найти растр, то он вырезает из имени растра путь (как абсолютный так и относительный) и продолжает поиск по пути указанному в методе SetProjectFilePath для объекта Preferences. При вставке растра Autocad присваивает ему имя основываясь на имени файла, без указания пути и расширения, его можно менять не боясь, что изменится и значение пути к файлу.

Модификация изображений и границ

Все растры имеют границы. Границы можно отобразить (скрыть), изменить цвет и тип линий, слой, переместить, масштабировать и вращать, делать растр невидимым и прозрачным, менять яркость, контрастность и т.д. Скрытие границ изображения позволяет избежать его случайного смещения и затрагивает все изображения. Чтобы изменить слой, цвет и тип линий границ - меняй значения свойств Layer, Color, LineType. Для изменения фактора масштабирования, вращения, положения, ширины и высоты есть следующие методы и свойства: ScaleEntity, Rotate, Origin, Width (в пикселях), Height (в пикселях), ImageWidth (в единицах вычерчивания), ImageHeight (в единицах вычерчивания), ShowRotation. Для изменения видимости изображения установи значение ImageVisibility=FALSE, это ускорит регенерацию. Для изменения прозрачности и цвета двуцветных (чернобелых) растров есть свойства Color и Transparency. Для регулировки Яркости, Контрастности и Затенения есть следующие свойства Brightness, Contrast, Fade. Подрезку изображений с помощью прямоугольных и полигональных границ можно выполнять независимо для каждой вставки одного и того же изображения. Для подрезки сначала следует включить ClippingEnabled=TRUE, затем методом ClipBoundary принимающим массив границ выполняем подрезку. Для изменения существующих границ подрезки нужно просто повторить то что сказано выше, при этом старые границы пропадут. Чтобы отобразить (скрыть) границу подрезки (вернуть оригинальные границы) используй свойство ClippingEnabled. Пример подрезки растрового изображения:

Sub ClippingRasterBoundary()
    Dim insertionPoint(0 To 2) As Double
    Dim scalefactor As Double
    Dim rotationAngle As Double
    Dim imageName As String
    Dim rasterObj As AcadRasterImage

    imageName = "C:\AutoCAD\sample\downtown.jpg"
    insertionPoint(0) = 5: insertionPoint(1) = 5: insertionPoint(2) = 0
    scalefactor = 2: rotationAngle = 0

    On Error GoTo ERRORHANDLER
    ' Вставить растр в пространство модели
    Set rasterObj = ThisDrawing.ModelSpace.AddRaster(imageName, insertionPoint, _
                     scalefactor, rotationAngle)
    ZoomExtents

    ' Задать границы подрезки в виде массива точек
    Dim clipPoints(0 To 9) As Double
    clipPoints(0) = 6: clipPoints(1) = 6.75
    clipPoints(2) = 7: clipPoints(3) = 6
    clipPoints(4) = 6: clipPoints(5) = 5
    clipPoints(6) = 5: clipPoints(7) = 6
    clipPoints(8) = 6: clipPoints(9) = 6.75

    ' Подрезать
    rasterObj.ClipBoundary clipPoints

    ' Разрешить отображение подрезки
    rasterObj.ClippingEnabled = True
    ThisDrawing.Regen acActiveViewport
    Exit Sub

ERRORHANDLER:
    MsgBox Err.Description
End Sub

Работа с блоками, атрибутами и внешними ссылками

Используя внешние ссылки монжно вставлять или накладывать в рисунок другой рисунок, при этом любые изменения, сделанные во вставленном рисунке, будут отображаться в основном.

Блок представляет собой набор объектов, который может быть собран в один объект или блочную ссылку. Полученный блок можно вращать, масштабировать, вставлять многократно как единое целое, но можно также "взорвать" на исходные составляющие, чтобы переопределить. Autocad обновляет все вхождения блока, после того как блок был переопределен. Использование блоков ускоряет процесс вычерчивания. Их можно применять, например, для построения стандартной библиотеки наиболее часто используемых символов, для экономии места на диске, когда вместо множества подобных объектов вставляется ссылка на один объект. Как только блок вставлен в рисунок - создается блочная ссылка. Каждый раз, вставляя блочную ссылку можно назначить масштаб и угол вращения, причем масштаб может быть различен по каждой оси координат.

Блоки могут наследовать цвета и типы линий от того слоя в котором расположены элементы их составляющие. При каждой вставке они создают соответствующие слои и типы линий. Блочная ссылка, состоящая из объектов, нарисованных на слое 0, с цветом и типом линий "по слою", помещенная на текущий слой наследует цвет и тип линий у слоя. Свойства текущего слоя заменяют свойства цвета и типа линий явно заданные блочной ссылке.

Блочная ссылка, состоящая из объектов, у которых цвет и тип линий заданы "по блоку" позволяет назначать их вставленной блочной ссылке, т.е. если сменить цвет блока на красный, то изменится цвет всех элементов. Блоки могут быть вложенными, единственное ограничение в том, что блок не может ссылаться сам на себя. Для создания нового блока используется метод Add, который требует два параметра - место размещения блока и имя блока. После создания к блоку можно добавлять любые геометрические объекты или другие блоки, после чего можно вставлять в рисунок вхождения блока. Можно также создать блок методом Wblock, группируя объекты во внешний файл. Autocad рассматривает любой чертеж, вставленный в текущий, как блок. Метод InsertBlock используется для вставки блочной ссылки в рисунок, он принимает шесть параметров: точка вставки, имя вставляемого блока, масштабы по осям координат (три параметра), и угол поворота.

Если после вставки блока из внешнего файла во внешнем файле произошли изменения, то это не отражается на вставленном блоке, если необходимо видеть изменения, то блок следует вставить повторно методом InsertBlock. При вставке рисунка в качестве блока имя блока присваивается по имени вставленного файла. Изменить имя блока можно, сменив значение свойства Name. По умолчанию для вставки Autocad использует координаты (0,0,0) как координаты базовой точки. Изменить координаты базовой точки можно методом SetVariable для переменной INSBASE. При следующей вставке будет использоваться новая базовая точка. Если вставленный рисунок содержит объекты пространства листа, они не будут включены в текущее определение блока. Для использования объектов пространства листа в другом рисунке откройте исходный рисунок и используйте метод Add чтобы определить объект пространства листа как блок. Вставлять рисунок можно как в пространство модели, так и в пространство листа. Составляющие блок объекты не могут быть перечисленны, однако возможно перечисление оригинального определения блока, можно так же взорвать блок для этой цели. Вставлять блок можно также методом AddMInsertBlock, который вставляет массив блоков. Пример определения и вставки блока:

Sub InsertingABlock()
    ' Определим блок
    Dim blockObj As AcadBlock
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0: insertionPnt(1) = 0: insertionPnt(2) = 0
    Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "CircleBlock")

    ' Добавим в блок окружность
    Dim circleObj As AcadCircle
    Dim center(0 To 2) As Double
    Dim radius As Double
    center(0) = 0: center(1) = 0: center(2) = 0: radius = 1
    Set circleObj = blockObj.AddCircle(center, radius)

    ' Вставим блок
    Dim blockRefObj As AcadBlockReference
    insertionPnt(0) = 2: insertionPnt(1) = 2: insertionPnt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
               (insertionPnt, "CircleBlock", 1#, 1#, 1#, 0)
    ZoomExtents
    MsgBox "Окружность стала блоком "  blockRefObj.ObjectName
End Sub

Примечание: после вставки внешнего файла WCS выравнивается параллельно плоскости XY, UCS текущего рисунка. Метод Explode позволяет разбить блок на составляющие, после чего удалить или отредактировать и переопределить блок. Следующий пример создает блок, затем его взрывает и показывает составляющие.

Sub ExplodingABlock()
    ' Определим блок
    Dim blockObj As AcadBlock
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0: insertionPnt(1) = 0: insertionPnt(2) = 0
    Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "CircleBlock")

    ' Добавим окружность
    Dim circleObj As AcadCircle
    Dim center(0 To 2) As Double
    Dim radius As Double
    center(0) = 0: center(1) = 0: center(2) = 0: radius = 1
    Set circleObj = blockObj.AddCircle(center, radius)

    ' Вставим блок
    Dim blockRefObj As AcadBlockReference
    insertionPnt(0) = 2: insertionPnt(1) = 2: insertionPnt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
               (insertionPnt, "CircleBlock", 1#, 1#, 1#, 0)
    ZoomExtents
    MsgBox "Окружность стала "  blockRefObj.ObjectName

    ' Взорвем блочную ссылку
    Dim explodedObjects As Variant
    explodedObjects = blockRefObj.Explode

    ' Перечислим полученные обломки
    Dim I As Integer
    For I = 0 To UBound(explodedObjects)
        explodedObjects(I).Color = acRed
        explodedObjects(I).Update
        MsgBox "Обломок "  I  ": "  explodedObjects(I).ObjectName
        explodedObjects(I).Color = acByLayer
        explodedObjects(I).Update
    Next
End Sub

Переопределение блока

Для переопределения блока затронь любой его метод или свойство, при этом все вхождения блока немедленно обновятся. Переопределение затрагивает как ранее вставленные блочные ссылки, так и те, что будут вставлены позже. Постоянные атрибуты утрачиваются и заменяются новыми, переменные атрибуты не меняются, даже если новый блок не имеет атрибутов. Пример переопределения блока

Sub RedefiningABlock()
    ' Определим блок
    Dim blockObj As AcadBlock
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0: insertionPnt(1) = 0: insertionPnt(2) = 0
    Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "CircleBlock")

    ' Добавим окружность
    Dim circleObj As AcadCircle
    Dim center(0 To 2) As Double
    Dim radius As Double
    center(0) = 0: center(1) = 0: center(2) = 0: radius = 1
    Set circleObj = blockObj.AddCircle(center, radius)

    ' Вставим блок
    Dim blockRefObj As AcadBlockReference
    insertionPnt(0) = 2: insertionPnt(1) = 2: insertionPnt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
               (insertionPnt, "CircleBlock", 1#, 1#, 1#, 0)
    ZoomExtents

    ' Переопределим блок
    circleObj.radius = 3
    blockRefObj.Update
End Sub

Работа с атрибутами

Атрибуты позволяют присоединить к блоку текст комментария. Атрибуты можно извлекать и помещать в базу данных или электронную таблицу. С блоком может быть связано более одного атрибута. Можно определять постоянные атрибуты, которые при вставке блока не требуют ввода значения. Атрибуты могут быть невидимыми. Чтобы создать атрибутную ссылку сначала следует определить атрибут методом AddAttribute который требует шесть параметров: высота текста, режим, строка подсказки, точка вставки, строка - имя атрибута, значение атрибута по-умолчанию. Режим указывать не обязательно. Возможны следующие варианты acAttributeModeNormal, acAttributeModeInvisible, acAttributeModeConstant, acAttributeModeVerify, acAttributeModePreset. Если нужно указать несколько атрибутов, то следует просто сложить константы им соответствующие, например acAttributeModeInvisible + acAttributeModeConstant.

Строка подсказки появляется при вставке блока с атрибутами, по-умолчанию ее значение равно имени (тэгу) атрибута. При acAttributeModeConstant подсказка не выводится. В качестве тэгов можно использовать любые символы кроме пробелов и восклицательных знаков, символы нижнего регистра преобразуются в верхний. После того как атрибут определен при вставке блока можно указать другое значение атрибута. Атрибуты связаны с блоком, в котором они создавались. Атрибуты, созданные в пространстве модели или листа, рассматриваются как не принадлежащие к блокам. Пример определения атрибутов:

Sub CreatingAnAttribute()
    ' Определим блок
    Dim blockObj As AcadBlock
    Dim insPnt(0 To 2) As Double
    insPnt(0) = 0: insPnt(1) = 0: insPnt(2) = 0
    Set blockObj = ThisDrawing.Blocks.Add(insPnt, "BlkWithAttr")

    ' Добавим к нему атрибут
    Dim attributeObj As AcadAttribute
    Dim height As Double
    Dim mode As Long
    Dim prompt As String
    Dim insPoint(0 To 2) As Double
    Dim tag As String
    Dim value As String
    height = 1
    mode = acAttributeModeVerify
    prompt = "New Prompt"
    insPoint(0) = 5: insPoint(1) = 5: insPoint(2) = 0
    tag = "New Tag": value = "New Value"
    Set attributeObj = blockObj.AddAttribute(height, mode, prompt, insPoint, tag, value)
    ' Вставим блок, создадим блочную ссылку и атрибутную ссылку
    Dim blockRefObj As AcadBlockReference
    insPnt(0) = 2: insPnt(1) = 2: insPnt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insPnt, "BlkWithAttr", 1#, 1#, 1#, 0)
End Sub

Редактирование определения атрибутов

Свойства:

Методы:

Переопределение атрибутов

Sub RedefiningAnAttribute()
    ' Определим блок
    Dim blockObj As AcadBlock
    Dim insPnt(0 To 2) As Double
    insPnt(0) = 0: insPnt(1) = 0: insPnt(2) = 0
    Set blockObj = ThisDrawing.Blocks.Add(insPnt, "BlkWithAttr")

    ' Добавим атрибут
    Dim attributeObj As AcadAttribute
    Dim height As Double
    Dim mode As Long
    Dim prompt As String
    Dim insPoint(0 To 2) As Double
    Dim tag As String
    Dim value As String
    height = 1
    mode = acAttributeModeVerify
    prompt = "New Prompt"
    insPoint(0) = 5: insPoint(1) = 5: insPoint(2) = 0
    tag = "New Tag": value = "New Value"
    Set attributeObj = blockObj.AddAttribute(height, mode, prompt, insPoint, tag, value)
    ' Вставим блок, создадим блочную и атрибутную ссылки
    Dim blockRefObj As AcadBlockReference
    insPnt(0) = 2: insPnt(1) = 2: insPnt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insPnt, "BlkWithAttr", 1#, 1#, 1#, 0)

    ' Переопределим направление текста
    attributeObj.Backward = True
    attributeObj.Update
End Sub

Извлечение информации из атрибутов

Для извлечения атрибутов есть два метода GetAttributes и GetConstantAttributes. Первый из них возвращает массив атрибутных ссылок присоединенных к блоку. Второй метод возвращает массив постоянных атрибутов (не ссылок). По полученному массиву можно пройти, просматривая свойства TagString и TextString для получения информации о каждом атрибуте. Пример извлечения атрибутов:

Sub GettingAttributes()
    ' Создаем блок
    Dim blockObj As AcadBlock
    Dim insPnt(0 To 2) As Double
    insPnt(0) = 0: insPnt(1) = 0: insPnt(2) = 0
    Set blockObj = ThisDrawing.Blocks.Add(insPnt, "TESTBLOCK")
    
    ' определим атрибуты
    Dim attributeObj As AcadAttribute
    Dim height As Double
    Dim mode As Long
    Dim prompt As String
    Dim insPoint(0 To 2) As Double
    Dim tag As String
    Dim value As String
    height = 1#
    mode = acAttributeModeVerify
    prompt = "Attribute Prompt"
    insPoint(0) = 5: insPoint(1) = 5:insPoint(2) = 0
    tag = "Attr Tag"
    value = "Attr Value"
    ' Создаем определение атрибута в блоке
    Set attributeObj = blockObj.AddAttribute(height, mode, prompt, insPoint, tag, value)

    ' Вставим блок
    Dim blockRefObj As AcadBlockReference
    insPnt(0) = 2: insPnt(1) = 2: insPnt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insPnt, "TESTBLOCK", 1, 1, 1, 0)
    ZoomAll
    
    ' Получить атрибуты для блочной ссылки
    Dim varAttributes As Variant
    varAttributes = blockRefObj.GetAttributes
    
    ' Поместим Тэг и содержимое текстовой части
    ' атрибута в Msgbox
    Dim strAttributes As String
    strAttributes = ""
    Dim I As Integer
    For I = LBound(varAttributes) To UBound(varAttributes)
        strAttributes = strAttributes + "  Tag: " + _
        varAttributes(I).TagString + vbCrLf + _
        "   Value: " + varAttributes(I).textString
    Next
    MsgBox "Атрибуты для блочной ссылки " + _
                   blockRefObj.Name  " : "  vbCrLf  strAttributes
    
   ' Изменим значение атрибута
   ' Не SetAttributes. Если есть массив то он является объектом.
   ' Изменение его изменяет объекты чертежа.
    varAttributes(0).textString = "NEW VALUE!"
    
    ' Снова получим атрибуты
    Dim newvarAttributes As Variant
    newvarAttributes = blockRefObj.GetAttributes
    
    ' Снова отобразим
    strAttributes = ""
    For I = LBound(varAttributes) To UBound(varAttributes)
        strAttributes = strAttributes + "  Tag: " + _
        newvarAttributes(I).TagString + vbCrLf + _
        "   Value: " + newvarAttributes(I).textString
    Next
    MsgBox "Атрибуты для блочной ссылки "  _
                  blockRefObj.Name  " : "  vbCrLf  strAttributes
End Sub    

Использование внешних ссылок

Внешняя ссылка связывает текущий чертеж с другим чертежом. При вставке другого чертежа как блока информация о его геометрии сохраняется в базе чертежа. Она не обновляется, если исходный чертеж изменился. Однако если вставлять другой чертеж как внешнюю ссылку, все изменения сразу отображаются. Подобно блочной ссылке внешняя ссылка отображается в рисунке единым объектом, однако внешняя ссылка не может быть "взорвана". Как и с блоками, можно создавать вложения внешних ссылок.

При открытии или печати рисунка Autocad перезагружает каждую внешнюю ссылку, чтобы отобразить ее в "свежайшем" виде. В отличие от блока при вставке внешней ссылки в чертеж вставляется только определение, а не сам файл. Если файл внешней ссылки отсутствует или поврежден, то Autocad его просто не отображает. Если значение системной переменной VISRETAIN=On Autocad сохраняет любую информацию о зависимых от внешней ссылки слоях в базе данных чертежа и она используется при следующем открытии. Можно вставлять неограниченное число внешних ссылок. Можно также управлять слоями и типами линий внешней ссылки. Для добавления внешней ссылки используйте метод AttachExternalReference. Он требует путь и имя вставляемого файла, имя ссылки, точку вставки, масштаб и угол вращения и возвращает объект ExternalReference. Пример:

Sub AttachingExternalReference()
    On Error GoTo ERRORHANDLER
    Dim InsPoint(0 To 2) As Double
    Dim insertedBlock As AcadExternalReference
    Dim tempBlock As AcadBlock
    Dim msg As String, PathName As String
    
    ' определим внешнюю ссылку
    InsPoint(0) = 1: InsPoint(1) = 1: InsPoint(2) = 0
    PathName = "c:/acad2002/sample/db_samp.dwg"
    
    ' Отобразим информацию о блоках
    GoSub ListBlocks
    
    ' Добавим внешнюю ссылку
    Set insertedBlock = ThisDrawing.ModelSpace. _
    AttachExternalReference(PathName, "XREF_IMAGE", InsPoint, 1, 1, 1, 0, False)
    ZoomExtents
    
    ' Отобразим информацию о блоках
    GoSub ListBlocks
    Exit Sub
ListBlocks:
    msg = vbCrLf
    For Each tempBlock In ThisDrawing.Blocks
        msg = msg  tempBlock.Name  vbCrLf
    Next
    MsgBox "Блоки в чертеже: "  msg
    Return
    
ERRORHANDLER:
    MsgBox Err.Description
End Sub

Наложение внешних ссылок подобно присоединению, отличие только в том, как обрабатываются вложенные ссылки. В случае наложения - вложенные ссылки просто не отображаются. Наложение удобно использовать толгда когда конечному потребителю не нужны дополнительные детали созданного вами чертежа, который используется в качестве внешней ссылки. То есть этот тип ссылок предназначен для совместного использования данных. Кроме того, он позволяет избежать цикличесских ссылок. Чтобы ссылка была наложением, измените параметр метода AttachExternalReference на bOverlay=TRUE. Для исключения ссылки из рисунка нужно его оттсоединить, можно также стереть конкретное вхождение ссылки. Ссылка самоуничтожается при следующем открытии чертежа, если уже нет ни одного ее вхождения. Для отсоединения ссылки используй метод Detach. Нельзя, однако, отсоединить вложенную ссылку. Пример отсоединения ссылки:

Sub DetachingExternalReference()
    On Error GoTo ERRORHANDLER
                          
    ' Определим внешнюю ссылку
    Dim xrefHome As AcadBlock
    Dim xrefInserted As AcadExternalReference
    Dim insertionPnt(0 To 2) As Double
    Dim PathName As String
    insPnt(0) = 1: insPnt(1) = 1: insPnt(2) = 0
    PathName = "c:/acad2002/sample/db_samp.dwg"
    
    ' Добавим внешнюю ссылку
    Set xrefInserted = ThisDrawing.ModelSpace. _
        AttachExternalReference(PathName, "XREF_IMAGE", insPnt, 1, 1, 1, 0, False)
    ZoomExtents
    MsgBox "Внешняя ссылка присоединена."
    
    ' Остосединим внешнюю ссылку
    Dim name As String
    name = xrefInserted.name
    ThisDrawing.Blocks.Item(name).Detach
    MsgBox "Внешняя ссылка отсоединена."
    Exit Sub
ERRORHANDLER:
    MsgBox Err.Description
End Sub

Выгрузка внешних ссылок

Для ускорения работы часть (или все) внешних ссылок можно выгрузить методом Unload. Пример:

Sub UnloadingExternalReference()
    On Error GoTo ERRORHANDLER
                          
    ' Определим внешнюю ссылку
    Dim xrefHome As AcadBlock
    Dim xrefInserted As AcadExternalReference
    Dim insPnt(0 To 2) As Double
    Dim PathName As String
    insPnt(0) = 1: insPnt(1) = 1: insPnt(2) = 0
    PathName = "c:/AutoCAD/sample/db_samp.dwg"
    
    ' Добавим внешнюю ссылку
    Set xrefInserted = ThisDrawing.ModelSpace. _
        AttachExternalReference(PathName, "XREF_IMAGE", insPnt, 1, 1, 1, 0, False)
    ZoomExtents
    MsgBox "Добавлена внешняя ссылка."
    
    ' Выгрузим определение внешней ссылки
    ThisDrawing.Blocks.Item(xrefInserted.name).Unload
    MsgBox "Внешняя ссылка выгружена."
    Exit Sub
ERRORHANDLER:
    MsgBox Err.Description
End Sub

Привязка внешней ссылки

Привязка внешней ссылки делает ее постояннной частью рисунка, а не внешней ссылкой. То есть она становится блоком, отсюда следует что при изменении чертежа внешней ссылки в основном чертеже никаких изменений не получим. После привязки любые именованные объекты (блоки, размерные стили, слои, типы линий и стили текста) могут использоваться в основном рисунке. Метод Bind требует только один параметр bPrefixName, если он равен TRUE, то символьные имена получают префикс по имени блока + цифровой идентификатор. В противном случае символьные имена сливаются с уже существующими и при наличии совпадаений оставляются уже определенные в основном рисунке. Если Вы не уверены, будут ли в связываемой внешней ссылке дублироваться имена, используйте TRUE. Пример связывания:

Sub BindingExternalReference()
    On Error GoTo ERRORHANDLER
                          
    ' Определим внешнюю ссылку
    Dim xrefHome As AcadBlock
    Dim xrefInserted As AcadExternalReference
    Dim insPnt(0 To 2) As Double
    Dim PathName As String
    insPnt(0) = 1: insPnt(1) = 1: insPnt(2) = 0
    PathName = "c:/AutoCAD/sample/db_samp.dwg"
    
    ' Добавим внешнюю ссылку
    Set xrefInserted = ThisDrawing.ModelSpace. _
        AttachExternalReference(PathName, "XREF_IMAGE", insPnt, 1, 1, 1, 0, False)
    ZoomExtents
    MsgBox "Внешняя ссылка присоединена."
    
    ' Привяжем определение внешней ссылки
    ThisDrawing.Blocks.Item(xrefInserted.name).Bind False
    MsgBox "Внешняя ссылка связана."
    Exit Sub
ERRORHANDLER:
    MsgBox Err.Description
End Sub

Не существует метода для обрезки блока или внешней ссылки в ActiveX, поэтому, если очень нужно, используйте метод SendCommand, вызывая команду XCLIP.

Загрузка по требованию и повышение производительности внешних ссылок

Комбинируя загрузку по требованию и сохранение чертежа с индексами можно увеличить скорость работы рисунков с внешними сслыками. Загрузка по требованию работает совместно с системными переменными XLOADCTL и INDEXCTL. Когда включена загрузка по требованию (при условии что были сохранены индексы в подчиненных рисунках), Autocad загружает в память только данные, которые нужны для регенирации текущего чертежа. Наиболее заметен выигрыш в производительности при использовании загрузки по требованию, когда внешняя ссылка подрезана и пространственный индекс сохранен во внешнем рисунке, а также в случае заморозки некоторых слоев внешней ссылки, а чертеж-внешняя ссылка сохранен с индексом слоя. Чтобы включить загрузку по требованию, есть свойство XRefDemandLoad. Если оно включено с параметром acDemandLoadEnabledWithCopy, Autocad создает временную копию файла внешней ссылки и загружает по требованию временный файл. При этом исходный файл внешней ссылки можно в этот момент редактировать. А когда загрузка по требованию отменена, Autocad загружает весь файл внешней ссылки, не обращая внимание на видимость слоев или обрезку. Для включения слоев и пространственных индексов установи значение переменной INDEXCTL таким образом - (0 - не создавать индексы, 1 - создать индекс слоев, 2 - создать пространственный индекс, 3 - создать оба индекса).

Пространственный индекс - список примитивов и данных их положения в трехмерном пространстве (используется при частичном открытии файла).

Индекс слоев - список слоев с перечнем объектов на них. По умолчанию файлы создаются без индексов.

Назначение и чтение расширенных данных

Объектам могут назначаться расширенные данные (дополнительная информация). Примеры установки и чтения:

Sub AttachXDataToSelectionSetObjects()
    ' Создаем набор
    Dim sset As Object
    Set sset = ThisDrawing.SelectionSets.Add("SS1")
    
    ' Предложим пользователю выбрать объекты
    sset.SelectOnScreen
    
    ' Определим расширенные данные
    Dim appName As String, xdataStr As String
    appName = "MY_APP"
    xdataStr = "Пример xdata (дополнительных данных)"
    Dim xdataType(0 To 1) As Integer
    Dim xdata(0 To 1) As Variant
    
    ' Зададим значения для каждого массива
    ' 1001 = appName
    xdataType(0) = 1001
    xdata(0) = appName
    ' 1000 отображает строковое значение
    xdataType(1) = 1000
    xdata(1) = xdataStr
    
    ' Проходим по элементам набора и устанавливаем
    ' каждому расширенные данные
    Dim ent As Object
    For Each ent In sset
        ent.SetXData xdataType, xdata
    Next ent
End Sub

Sub ViewXData()
    ' Ищем набор, созданный в предыдущем примере
    Dim sset As Object
    Set sset = ThisDrawing.SelectionSets.Item("SS1")
    
    ' Создаем переменные для хранения расширенных данных
    Dim xdataType As Variant
    Dim xdata As Variant
    Dim xd As Variant
    
    Dim xdi As Integer
    xdi = 0
    
    ' Проходим по всем объектам набора, читая расширенные данные
    Dim msgstr As String
    Dim appName As String
    Dim ent As AcadEntity
    appName = "MY_APP"
    For Each ent In sset
        msgstr = ""
        xdi = 0
        
        ' Имя приложения (appName) xdata Тип и Значение
        ent.GetXData appName, xdataType, xdata
        
        ' Если переменная xdataType не инициализирована, не
        ' будет appName xdata
        If VarType(xdataType) <> vbEmpty Then
            For Each xd In xdata
                msgstr = msgstr  vbCrLf  xdataType(xdi)  ": "  xd
                xdi = xdi + 1
            Next xd
        End If
        
        ' Если полученная строка пуста (NULL), нет расширенных данных
        If msgstr = "" Then msgstr = vbCrLf  "NONE"
        MsgBox appName  " xdata "  ent.ObjectName  ":"  vbCrLf  msgstr
    Next ent
End Sub

Разработка приложений с помощью vba

Далее последует краткий обзор методам обработки ошибок, управления фокусом окон и создания дистрибутивов.

Для отображения и скрытия формы используются методы Show и Hide

Public Sub MyApplication()
   UserForm1.Show
   UserForm1.Hide
End Sub

Все формы в VBA модальные, то есть пока их не закроешь невозможно что-либо править в чертеже. Когда форма скрыта уже возможно кое-что править. Форму можно загрузить, но сразу не отображать. С целью освобождения памяти ненужные формы можно выгружать методом Unload.

Все диалоговые окна в VBA также модальны, то есть если применяешь диалоговое окно в котором от пользователя ожидается выбор элементов на рисунке путем их указания следует сначала скрыть окно диалога, а по окончании выбора - показать.

Из трех типов ошибок (периода компиляции, логических и периода выполнения) обработать программным путем в полной мере можно только последние. Их следует отслеживать в местах наиболее вероятного появления и обрабатывать. Обработчик по-умолчанию только отображает окно с кодом ошибки и предлагает либо перейти в отладчик, либо завершить выполнение программы. Обычно обработчики ошибок ставятся в тех местах, где ожидается ввод от пользователя или файловый ввод-вывод. Для обработки ошибок в VBA используется оператор On Error который имеет три формы:

Первый метод позволяет просто игнорировать ошибку и продолжать выполнение оператора, следующего за оператором, вызвавшим ошибку, не отображая сообщения об ошибке. Это удобно, например, при смене цвета путем циклического перебора всех объектов, если при этом программа натолкнется на элемент, находящийся на заблокированном слое, то просто игнорирует ошибку:

Sub ColorEntities()
    Dim entry As Object
    On Error Resume Next
    For Each entry In ThisDrawing.ModelSpace
        entry.Color = acRed
    Next entry
End Sub

Вариант On Error GoTo Label используется, если нужно написать особый обработчик ошибки:

Sub ColorEntities2()
    Dim entry As Object
    On Error GoTo MyErrorHandler
    For Each entry In ThisDrawing.ModelSpace
        entry.Color = acRed
    Next entry
    ' Важно! Выйти из программы чтобы не нарваться на обработчик ошибок
    Exit Sub
MyErrorHandler:
    Msgbox entry.EntityName + " на блокированном слое." + " хэндл: " + entry.Handle
    Resume Next
End Sub

Вариант On Error GoTo 0 отменяет текущий обработчик ошибок. Обработка ошибок завершается окончанием процедуры обработчика, новым обработчиком ошибок или переходом по "нулевой" метке.

Объект Err обладает следующими свойствами Number, Description, Source, HelpFile, HelpContext, и LastDLLError. Наиболее важны из них первые три (код ошибки, ее описание и источник). Использование метода InitializeUserInput перед получением ввода от пользователя ограничивает количество возможных ошибок.

Зашифровать и защитить паролем программу на VBA возможно через Tools=>Project>Properties=>Protection.

Чтобы запустить макрос VBA из командной строки

 -VBARUN Filename.dvb!projectname.macroname

При этом указывать имя файла проекта нужно только в случае если он еще не загружен в текущем сеансе.

Автозагрузка проекта на VBA возможна двумя способами:

При загрузке Autocad просматривает каталог, откуда он запущен, на предмет наличия файла acad.dvb который и выполняется, если найден.

Любой другой проект можно включить в автозагрузку посредством команды VBALOAD.

В следующем примере используется файл автозагрузки autolisp для запуска VBA и запуска проекта myproj.dvb. Эти строчки нужно добавить в acad.lsp

(defun S::STARTUP()
   (command "_VBALOAD" "myproj.dvb")
)
Для автоматического выполнения макроса из acad.dvb можно сделать так 

(defun S::STARTUP()
   (command "_VBARUN" "drawline")
)

Также при загрузке VBA автовыполняется макрос с именем AcadStartup.

Работа с VBA когда не открыт ни один документ

Если ни один документ не открыт, то возникнут следующие особенности:

Распространение программ

Возможны два варианта - внедрение в файл чертежа или отдельным файлом. В отдельном файле удобно хранить общие процедуры.

Взаимодействие с другими приложениями, базами данных и windows api

Для взаимодействия с другими приложениями через ActiveX нужно выполнить три основных операции:

Чтобы сделать ссылку на объектную библиотеку другого приложения, нужно в меню Tools - References указать нужное, после чего в окне просмотрщика объектов будут доступны объекты другого приложения. Чтобы создать экземпляр приложения, например, MSExcel, объявляется переменная-ссылка

Dim ExcelAppObj as Excel.Application 
и устанавливается указатель
Set ExcelAppObj = New Excel.Application

По окончании работы нужно закрыть запущенный экземпляр приложения: ExcelAppObj.Application.Quit. Пример переноса атрибутов из Autocad в Excel:

Sub Extract()
    Dim Excel As Excel.Application
    Dim ExcelSheet As Object
    Dim ExcelWorkbook As Object

    Dim RowNum As Integer,Header As Boolean
    Dim elem As AcadEntity,Array1 As Variant
    Dim Count As Integer
   ' Запуск Excel.
   Set Excel = New Excel.Application

   ' Создаем книгу Excel и ищем активный лист
   Set ExcelWorkbook = Excel.Workbooks.Add
   Set ExcelSheet = Excel.ActiveSheet
   ExcelWorkbook.SaveAs "Attribute.xls"

   RowNum = 1
   Header = False
   ' Проходим по пространству модели в поисках блочных ссылок
   For Each elem In ThisDrawing.ModelSpace
     With elem
         ' Если найдена блочная ссылка проверить атрибутоы
         If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
            If .HasAttributes Then
               ' Читаем атрибуты
               Array1 = .GetAttributes
               ' Копируем их в Excel
               For Count = LBound(Array1) To UBound(Array1)
                   If Header = False Then
                     If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                        ExcelSheet.Cells(RowNum, Count + 1).value = Array1(Count).TagString
                     End If
                   End If
               Next Count
               RowNum = RowNum + 1
               For Count = LBound(Array1) To UBound(Array1)
                   ExcelSheet.Cells(RowNum, Count + 1).value = Array1(Count).textString
               Next Count
               Header = True
            End If
         End If
     End With
   Next elem
   Excel.Application.Quit
End Sub

Работа с DAO (Data Access Object) для доступа к базам данным

С помощью DAO можно работать с любой базой данных, поддерживающих интерфейс Microsoft Jet, (Access, dBase, FoxPro, Paradox, а также базами данных ODBC MS SQL Server и Oracle). Возможности следующие: создание БД, изменение структуры, добавление таблиц, определение связей между ними, создание и выполнение запросов, добавление, изменение или удаление записей. Для всего это нужно выполнить три основных шага:

Для выполнения первого из этих шагов следует в среде VBA IDE выбрать пункт меню Tools - References и поставить галочку против Microsoft DAO Object Library. После чего все объекты, методы и свойства DAO станут доступными для просмотра в "просмотрщике" объектов. Причем установленная ссылка действует только для текущего проекта.

Второй шаг (открытие базы данных) можно выполнить так:

Dim db As Database
Set db = DBEngine.Workspaces(0).OpenDatabase("C:\TEST.MDB")

Наиболее важным и часто используемым объектом в DAO является объект RecordSet представляющий набор записей, возвращаемых таблицей на основе запроса SQL. Вообще по этому поводу необходимо ознакомиться со справочной системой Microsoft Access.

Доступ к Windows API из VBA

Функции Windows API доступны для любых приложений и позволяют реализовать все возможности программирования под Windows. Чтобы этим воспользоваться, следует сначала объявить функцию Windows API, с помощью оператора Declare. В качестве параметров требуется указание имени динамической библиотеки (DLL), содержащей нужную функцию, имя процедуры как она называется в DLL, имя процедуры, как она будет называться в вашей программе, параметров процедуры, которые она ожидает, типа возвращаемых данных, если процедура вызывается как функция.

Оператор Declare можно поместить в любое место программы, так если его поместить в стандартном модуле, то процедура будет доступна для любого модуля программы, если конечно не ограничить диапазон ее действия ключевым словом Private. Если объявить процедуру в модуле формы или класса, то она только там и будет доступна. Использование оператора Declare довольно сложно и требует хороших знаний от программиста, т.к. очень легко ошибиться, что может привести к тяжелым последствиям. Для облегчения данного процесса Microsoft создала специальные файлы в которых уже прописано объявление большинства часто используемых процедур. Они хранятся в файле Win32api.txt, поставляемым совместно с Visual Basic и Office. За дополнительной информацией обращаться к MSDN.

Создание диалоговых окон в VBA

Диалоговое окно создается в редакторе VBA в виде формы по команде Insert - UserForm. Возникает пустая форма, ограниченная маркерами. Одновременно возникают панель инструментов ToolBox (рис.8.1).

Как правило, оформление формы производят вручную, хотя можно это выполнить в программе. Элементы управления перетаскивают на форму мышью из панели ToolBox. Свойства выбирают или устанавливают в окне Properties.

На панели ToolBox имеются следующие элементы управления:

Задание 8.1

Создать три одинаковых тора . Радиусы малой и большой окружностей задать в диалоговом окне. Соединить все три тора либо в конструкцию "тор в торе" либо цепочкой. Закрасить торы в три последовательных цвета.

Составим таблицу элементов управления для UserForm:

Разместим элементы на форме, например, так, как показано на рис.8.1. Текстовые надписи выполнены с помощью инструмента Label. Текстовые поля созданы элементом TextBox, а числовые значения вписаны в них в строке Text окна Properties. Переключатели (радиокнопки) установлены путем перетаскивания на форму элементов OptionButton. Кнопки с надписями OK и Cancel образованы элементом управления CommandButton. Имена элементам следует задавать близкие к выполняемым ими функциям.

При выделенной форме нужно открыть модуль и записать там процедуру инициализации. Наиболее краткая форма этой процедуры выглядит так:

Public Sub Torus()
TorsForm.Show
End Sub

Обычно в файле инициализации производят заполнение списков, вносят первоначальные данные в текстовые окна, включают радиокнопки и флажки. Чтобы составить процедуру для элемента формы, нужно выделить этот элемент двойным щелчком мыши. В открывшемся модуле будет подготовлена заготовка для процедуры.

Вставьте модуль и скопируйте в него следующий текст:

Private Sub Cancel_Click()
Unload Me
End Sub

Private Sub OK_Click()

Dim clr As Integer
Dim dCenter(0 To 2) As Double 'центр торов
Dim dY(0 To 2) As Double 'точка по Y
Dim dX(0 To 2) As Double ' точка по X
Dim toPointY(0 To 2) As Double 'точка по Y для смещения

Dim dRadius1           As Double                ' радиус тора
Dim dRadius2            As Double               ' радиус трубки тора
Dim dAng            As Double                  ' угол поворота тора
Dim MyTorus            As Acad3DSolid        ' тор
Dim Layer               As AcadLayer           'слой
Dim MyTorus1            As Acad3DSolid        ' тор
Dim Layer1               As AcadLayer       'слой
Dim MyTorus2            As Acad3DSolid        ' тор
Dim Layer2               As AcadLayer       'слой

            ' задание значений переменных:

'центр торов
dCenter(0) = 0#
dCenter(1) = 0#
dCenter(2) = 0#

'вторая точка для задания прямой вращения для поворота тора - прямая параллельна OY
dY(0) = 0#
dY(1) = 10#
dY(2) = 0#

'вторая точка для задания прямой вращения для поворота тора - прямая параллельна OX
dX(0) = 10#
dX(1) = 0#
dX(2) = 0#
' задание размеров тора:
'угол поворота вокруг осей
dAng = 3.14 / 2
dRadius2 = Val(TorsForm.smallRad.Text)
dRadius1 = Val(TorsForm.bigRad.Text)

'точка для перемещения
toPointY(0) = 0#
toPointY(1) = (4 * dRadius1) / 3

toPointY(2) = 0#

ThisDrawing.SendCommand ("_VSCURRENT R _VIEW Top ")
ThisDrawing.SendCommand ("setvar gridmode 0 ")
Set MyTorus1 = ThisDrawing.ModelSpace.AddTorus(dCenter, dRadius1, dRadius2)
If TorsForm.Red.Value Then clr = 1
If TorsForm.Yellow.Value Then clr = 2
If TorsForm.Green.Value Then clr = 3

Set MyTorus = ThisDrawing.ModelSpace.AddTorus(dCenter, dRadius1, dRadius2)
Call MyTorus.Rotate3D(dCenter, dY, dAng) 'поворот вокруг оси OY на 90

Set MyTorus2 = ThisDrawing.ModelSpace.AddTorus(dCenter, dRadius1, dRadius2)

If TorsForm.type1.Value Then
Call MyTorus2.Rotate3D(dCenter, dX, dAng) 'поворот вокруг оси OX на 90
Else
Call MyTorus.Move(dCenter, toPointY)
Call MyTorus2.Rotate3D(dCenter, dY, dAng) 'поворот вокруг оси OX на 90
toPointY(1) = -toPointY(1)
Call MyTorus2.Move(dCenter, toPointY)
End If

ThisDrawing.SendCommand ("_VPOINT 1,1,1 ")

'задание слоев, цветов торам
Set Layer1 = ThisDrawing.Layers.Add("Layer1") ' создание нового слоя
Layer1.color = clr 'задание слою цвета
MyTorus1.Layer = Layer1.Name 'присвоению тору нового слоя

Set Layer = ThisDrawing.Layers.Add("Layer")
Layer.color = clr + 1
MyTorus.Layer = Layer.Name

Set Layer2 = ThisDrawing.Layers.Add("Layer2")
Layer2.color = clr + 2
MyTorus2.Layer = Layer2.Name
Unload Me

End Sub
'изменяем демонстрационную картинку
Private Sub type1_Click()
TorsForm.Image1.Picture = LoadPicture(GetAppPath + "tor_in_tor.jpg")

End Sub
'изменяем демонстрационную картинку
Private Sub Type2_Click()
TorsForm.Image1.Picture = LoadPicture(GetAppPath + "chain.jpg")
End Sub

'получает директорию проекта
Public Function GetAppPath()
'путь к файлу проекта
Dim projFilePath As String
projFilePath = AcadApplication.ActiveDocument.Application.VBE.ActiveVBProject.FileName
'индекс последнего слэша в пути
Dim lastSlash As Integer
lastSlash = InStrRev(projFilePath, "\")
'директория проекта
GetAppPath = Replace(projFilePath, Replace(projFilePath, "\", "", lastSlash, Len(projFilePath) - lastSlash), "")
End Function

Private Sub UserForm_Initialize()
TorsForm.Image1.Picture = LoadPicture(GetAppPath + "tor_in_tor.jpg")
End Sub

Сохраните эту программу как файл Project_Torus.dvb. Картинки, приведенные ниже, сохраните в файлах Tor_in_tor.jpg и Chain.jpg. Файлы проекта и картинок поместите в одну папку.

Одной из задач программирования является организация интерактивности, т.е. возможности получения программой информации от пользователя. Это можно сделать двумя способами - из командной строки и через диалоговое окно.

Пример.

Рассмотрим обращение к объекту Utility. Он принадлежит объекту Document и управляет методами получения информации от пользователя.

Dim iReturn as Integer
iReturn = ThisDrawing.Utility.GetInteger ("Введите целое число: ")

Здесь переменной iReturn присваивается целое число, введенное пользователем в командную строку. Такой метод применяется для ввода коротких и простых данных: чисел, текста или объекта. Чтобы избежать появления нескольких приглашений в одной строке, используют константу vbCrLf в начале приглашения:

Prompt1 = vbCrLf  "Задайте центральную точку: "
Пример
Sub AddCircle ()
Dim vPt As Variant
Dim dRadius As Double
Dim myCircle As AcadCircle
vPt = ThisDrawing.Utility.GetPoint (, vbCrLf  "Введите точку центра: ")
dRadius = ThisDrawing.Utility.GetReal ("Введите радиус: ")
Set myCircle = ThisDrawing.ModelSpace.AddCircle (vPt, dRadius)
End Sub

Приведем перечень встроенных методов, наиболее часто применяемых для получения данных от пользователя. Во всех случаях приглашение является необязательным параметром.

Упражнение

Создать процедуру, получающую информацию от пользователя

Создайте новый чертеж. Выберите команду Tools - Macro - VBA Manager. Щелкните по кнопке NEW, а затем по кнопке Visual Basic Editor. Выберите команду Insert - Module, а затем Insert - Procedure. Наберите в модуле следующий текст:

Public Sub HappyFace()
Dim prompt As String, prompt2 As String
Dim cen As Variant
Dim rad As Double
Dim cir As AcadCircle
Dim arc As AcadArc
Dim pi As Double
Dim dStart As Double 'начальный угол
Dim dEnd As Double 'конечный угол
pi = 3.1415
prompt = vbCrLf  "Задайте центральную точку: "
prompt2 = vbCrLf  "Задайте радиус: "
'получение центральной точки и радиуса от пользователя
cen = ThisDrawing.Utility.GetPoint(, prompt)
rad = ThisDrawing.Utility.GetDistance(cen, prompt2)
Set cir = ThisDrawing.ModelSpace.AddCircle(cen, rad)
'рисуем улыбку
dStart = 225 * pi / 180 'pi/180 - перевод в радианы
dEnd = 315 * pi / 180
Set arc = ThisDrawing.ModelSpace.AddArc(cen, rad / 2, dStart, dEnd)
'рисуем глаза
cen(0) = cen(0) - rad / 4
cen(1) = cen(1) + rad / 4
Set cir = ThisDrawing.ModelSpace.AddCircle(cen, rad / 8)
cen(0) = cen(0) + rad / 2
Set cir = ThisDrawing.ModelSpace.AddCircle(cen, rad / 8)
End Sub

Сохраните проект как Project_HappyFace.dvb в папке AutoCAD2007\Support. Вернитесь к чертежу и выберите команду Tools - Macro - Macros. В диалоговом окне выберите процедуру HappyFace и щелкните по кнопке Run. Ответьте на приглашения.

В основе приведенного примера лежит функция GetDistance. Благодаря ей пользователь может задать радиус с помощью мыши. Указанная ранее точка центра будет использована функцией GetDistance в качестве опорной. Кроме того, процедура выполняет преобразование градусов в радианы. Поэтому расположение глаз и губ будет соотноситься и с центром, и с радиусом.

Как и во всех языках программирования, в VBA существует развитая технология поиска ошибок. Простейший сеанс отладки сводится к установке точек прерывания. Перейдите в редакторе в процедуру, где предполагается наличие ошибки. Поместите курсор в первую выполняемую строку и нажмите F9 или выберите команду Debug - Toggle Breakpoint. В строку будет добавлена точка прерывания.

Выполните операторы по одному, нажимая клавишу F8. На каждом шаге просматривайте значения переменных. При помещении указателя мыши на переменные типов Integer, Double, и String в подсказке выводится их текущее значение.

Когда ошибка обнаружена, выберите команду Run - Reset и внесите исправления в код. При следующем запуске процедуры точка прерывания останется активной. Отключить ее можно нажатием клавиши F9. Нормальный запуск процедуры можно осуществить командой Run Sub, либо нажатием клавиши F5.

Если программа зависает в редакторе Visual Basic, то выйдите в окно AutoCAD и прервите выполнение команды нажатием клавиши ESC.

Ключевые термины

Объектная модель AutoCAD - Иерархическая структура всех объектов AutoCAD.

Доступ - доступ к иерархии объектов, в частности, к свойствам и методам объекта Document, обеспечивается посредством объекта ThisDrawing.

Variant - тип, который может принимать данные любого типа, за исключением строк фиксированной длины и типов данных, определяемых пользователем.

Родительский объект - объект более высокого ранга. с которым данный объект постоянно связан. Все объекты имеют свойство Application, как непосредственную ссылку на корневой объект.

Пользовательская форма - диалоговое окно с элементами управления.

Реактор - процедура, которая дает возможность приложению реагировать на события, происходящие где угодно в AutoCAD.

Краткие итоги

Объектно-ориентированный язык VBA открывает широкие возможности автоматизации работы в среде AutoCAD. Все объекты AutoCAD организованы в виде иерархической структуры с корнем дерева в виде объекта Application. Связь VBA с активным чертежом AutoCAD обеспечивается посредством объекта ThisDrawing. С его помощью можно получить немедленный доступ ко всем свойствам и методам объекта Document, а также ко всем другим объектам иерархии. Кроме того, у всех объектов есть свойство Application, которое и является ссылкой на объект Application. Пользовательские формы VBA являются удобным способом создания диалоговых окон для введения в программу пользовательских данных.

Вопросы