Руководство vba autocad

Цель лекции: изучить принципы и конкретные технологии программирования на VBA.

Введение. Обзор команд. Объектная модель

Введение

Интерфейс AutoCAD ActiveX/VBA дает некотoрые преимущества по сравнению с другими методами создания приложений AutoCAD:

1. Высокая скорость выполнения процесса, так как в отличие от AutoLISP-приложений выполнение команд происходит внутри процесса;
2. Простота использования, обусловленная простотой языка программирования;
3. Большие возможности межпрограмного обмена, так как VBA и ActiveX разрабатывались для взаимодействия с другими Windows-приложениями.

Понятие внедренных и глобальных проектов VBA

Приложение Autocad VBA представляет собой набор программных модулей, модулей классов и форм. Пороект может быть сохранен как в рисунке (внедренный), так и во внешнем файле. Внедренный проект автоматически загружается при открытии рисунка. Ограничение внедренных проектов в том, например, что они не могут закрыть рисунок, внутри которого находятся. Глобальные проекты в этом плане более гибки, при этом однако пользователь должен знать где расположен файл в котором хранятся макросы. Глобальный проект проще передавать другим пользователям и в нем удобно хранить общие макросы. В любой момент могут быть использованы оба типа проектов. На уровне двоичного кода проект Autocad VBA не совместим с проектом Visual Basic, однако обмен формами, модулями и классами можно производить через экспорт- импорт. (Команды IMPORT и EXPORT VBA).

Загрузка существующего проекта

При загрузке проекта все глобальные процедуры, называемые так же макросами, становятся доступными для использования. Загрузить проект можно через VBA-менеджер или с командной строки VBALOAD. Кроме того автокад грузит автоматически проект с именем acad.dvb, который может найти в путях файлов поддержки. При загрузке проекта может появиться предупреждение, что он содержит макросы, а значит может содержать и вирусы. Выгрузка проекта командной VBAUNLOAD приводит к высвобождению памяти ранее занятой проектом. Внедрить проект в рисунок можно с помощью VBA-менеджера, он же позволяет извлечь проект из рисунка, при этом предлагая сохранить его в отдельном файле. Чтобы среда разработки VBA автоматически загрузилась при загрузке AutoCAD, в файл acad.arx нужно внести строку acadvba.arx.

Определение компонентов проекта

Проект может состоять из различных компонентов:

• объекты;
• формы;
• стандартные модули;
• модули класса;
• ссылки.

Добавить компонент можно через меню Insert, компоненты так же можно импортировать из файлов (.frm, .bas, .cls).

Обзор команд VBA AutoCAD

• VBAIDE— открывает окно VBA IDE, позволяющее редактировать, запускать и отлаживать программы.
• VBALOAD — загружает проект.
• VBARUN — запускает макрос на выполнение.
• VBAUNLOAD — выгружает проект, освобождая память.
• VBAMAN — показывает окно менеджера VBA.
• VBASTMT — позволяет выполнить команду VBA в командной строке AutoCAD.

Основные понятия объектной модели AutoCAD

Все объекты AutoCAD организованы в виде иерархической структуры. Корнем дерева является объект Application.

Через объект Application можно получить доступ к следующим объектам:

• Preferences;
• Documents;
• MenuBar;
• MenuGroups;

Через объект Preferences можно получить доступ к следующим объектам

• PreferencesDisplay;
• PreferencesDrafting;
• PreferencesFiles;
• PreferencesOpenSave;
• PreferencesOutput;
• PreferencesProfiles;
• PreferencesSelection;
• PreferencesSystem;
• PreferencesUser.

Через объект Documents можно получить доступ к объекту Document а через него к большинству других объектов и коллекций:

• Blocks (блоки)
• Dictionaries (словари)
• DimStyles (размерные стили)
• Groups (группы)
• Layers (слои)
• Layouts ()
• Linetypes (типы линий)
• PlotConfigurations (настройки плоттеров)
• RegisteredApplications (зарегистрированные приложения)
• SelectionSets (наборы)
• TextStyles (стили текста)
• UserCoordinateSystems (системы координат определенные пользователем)
• Views (виды)
• Viewports (видовые экраны)
• DatabasePreferences ()
• Plot (печать)
• Utility (служебные программы)
• ModelSpace (пространство модели)
• PaperSpace (пространство листа)

В двух последних расположены объекты AutoCAD, видимые на рисунке:

3DFace 
3DPoly 
3DSolid 
Arc 
Attribute 
AttributeReference 
BlockReference 
Circle 
Dim3PointAngular 
DimAligned 
DimAngular 
DimDiametric 
DimOrdinate 
DimRadial 
DimRotated 
Ellipse 
ExternalReference 
Hatch 
Leader 
LWPolyline 
Line 
MInsertBlock 
MLine 
MText 
Point 
PolyfaceMesh 
Polyline 
PolygonMesh 
RasterImage 
Ray 
Region 
Shape 
Solid 
Spline 
Text 
Tolerance 
Trace 
Xline 

Доступ к иерархии объектов. Коллекции, свойства и методы

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

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

Ссылка на объекты в иерархии объектов

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

Sub Test()
  Dim startPoint(0 To 2) As Double, endPoint(0 To 2) As Double
  Dim LineObj As AcadLine
  startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0
  endPoint(0) = 30: endPoint(1) = 20: endPoint(2) = 0
  Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
End Sub

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

Dim moSpace As AcadModelSpace
Set moSpace = ThisDrawing.ModelSpace

В примере добавляем линию в пространство модели, используя эту переменную:

 
Dim startPoint(0 To 2) As Double, endPoint(0 To 2) As Double
Dim LineObj as AcadLine
startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0
endPoint(0) = 30: endPoint(1) = 20: endPoint(2) = 0
Set LineObj = moSpace.AddLine(startPoint,endPoint)

Корневой объект Application расположен в иерархии выше объекта Document. Выше показано, что объект ThisDrawing обеспечивает доступ к объекту Document. А у объекта Document есть свойство Application, которое и является ссылкой на объект Application. Пример обращения:

ThisDrawing.Application.Update 

Коллекции объектов

Объект Collection — является предопределенным объектом содержащим все вхождения подобных объектов. Существуют следующие объекты коллекции:

• Documents — включает все открытые в текущей сессии документы
• ModelSpace — включает все графические объекты (entities — примитивы) пространства модели
• PaperSpace — включает все графические объекты пространства активного листа
• Block Object — включает все указанные определения блоков
• Blocks — включает все блочные ссылки рисунка
• Dictionaries — включает все словари (Dictionaries) рисунка
• DimStyles — включает все размерные стили рисунка
• Groups — включает все группы рисунка
• Hyperlinks — включает все гиперссылки рисунка
• Layers — включает все слои рисунка
• Layouts — включает все листы рисунка
• Linetypes — включает все типы линий рисунка
• MenuBar — включает все отображаемые AutoCADом меню
• MenuGroups — включает все меню и панели инструментов
• RegisteredApplications — включает все зарегистрированные приложения
• SelectionSets — включает все наборы рисунка
• TextStyles — включает все стили текста рисунка
• UCSs — включает все пользовательские системы координат рисунка
• Views — включает все Виды рисунка
• Viewports — включает все видовые экраны рисунка

Доступ к коллекции

Большинство коллекций доступны через объект Document, т.к. он содержит свойства для каждой из коллекций. Следующий код устанавливает ссылку объектной переменной на коллекцию Layers:

Dim layerCollection as AcadLayers
Set layerCollection = ThisDrawing.Layers

Коллекции Documents, MenuBar и MenuGroups доступны через объект Application. Он содержит свойства для каждой из этих коллекций. Следующий пример определяет объектную переменную и создает ссылку через нее на коллекцию:

Dim MenuGroupsCollection as AcadMenuGroups
Set MenuGroupsCollection = ThisDrawing.Application.MenuGroups

Добавление нового элемента коллекции

Следующий пример создает слой и добавляет его в коллекцию:

Dim newLayer as AcadLayer
Set newLayer = ThisDrawing.Layers.Add("MyNewLayer")

Перебор членов коллекции

Для выбора нужного члена коллекции используется метод Item. В качестве параметра ему передается номер (Index) объекта в коллекции либо его символьный идентификатор. Пример демонстрирует перебор всех слоев с отображением их имен

Sub IterateLayer()
  On Error Resume Next
  Dim I As Integer
  Dim msg As String
  msg = ""
  For I = 0 To ThisDrawing.Layers.count - 1
    msg = msg + ThisDrawing.Layers.Item(I).Name + vbCrLf
  Next
  MsgBox msg
End Sub

Пример поиска слоя с именем ABC:

Sub FindLayerABC()
  On Error Resume Next
  Dim ABCLayer As AcadLayer
  Set ABCLayer = ThisDrawing.Layers.Item("ABC")
  If Err <> 0 Then
    MsgBox "Слой 'ABC' не существует"
  End If
End Sub

Примечание

Не следует использовать методы редактирования примитивов (Copy, Array, Mirror и др.) на любом объекте который одновременно перебирается с помощью механизма For Each. В случае необходимости нужно закончить перебор, создать временный массив эквивалентный коллекции и в этом массиве выполнить редактирование.

Удаление члена коллекции

Пример удаления слоя:

Dim ABCLayer as AcadLayer
Set ABCLayer = ThisDrawing.Layers.Item("ABC")
ABCLayer.Delete

Удаленный объект восстановлению не подлежит.

Понятие свойств и методов

Каждый объект обладает связанными с ним свойствами и методами. Свойства описывают некоторые характеристики присущие объекту, а методы позволяют выполнять действия над объектами, в частности, менять и читать свойства. Например, объект окружность имеет свойство Центр, которое представляет трехмерную координату центра окружности. Чтобы сменить свойство достаточно задать ему другое значение. Окружность как целое имеет метод Offset, который создает новый объект на указанном смещении от существующего. Полный перечень свойств и методов есть в ActiveX and VBA Reference.

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

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

Библиотеки типов

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

Получение первого примитива из базы данных рисунка

Sub FindFirstEntity()
  On Error Resume Next
  Dim entity As AcadEntity
  If ThisDrawing.ModelSpace.count <> 0 Then
    Set entity = ThisDrawing.ModelSpace.Item(0)
    MsgBox entity.ObjectName + " первый примитив в пространстве модели."
  Else
    MsgBox "Нет ни одного объекта в пространстве модели."
  End If
End Sub

Применение variant в методах и свойствах

Для передачи массива данных AutoCAD использует тип Variant который может принимать данные любого типа за исключением строк фиксированной длины и типов данных, определяемых пользователем. Может также принимать значения Empty, Error, Nothing, NULL. Чтобы узнать какой именно тип данных хранятся в переменной типа Variant, нужно обратиться к функции VarType или TypeName.

Тип данных Variant используется для передачи массива данных из/в AutoCAD ActiveX Automation. В AutoCAD VBA-входные массивы автоматически преобразуются в тип Variant. Однако c выходными массивами все не так просто. Метод CreateTypedArray преобразует массив в Variant, содержащий «смесь» из Integer, Double и т.д. Эту «смесь» можно передать в любой метод или любое свойство AutoCAD, которые принимают массив чисел как Variant.

В примере преобразуются три массива координат сплайна с передачей их методу AddSpline.

Sub CreateSplineUsingTypedArray()
  Dim splineObj As AcadSpline
  Dim startTan As Variant, endTan As Variant, fitPoints As Variant
  Dim noOfPoints As Integer
  Dim utilObj As Object
  Set utilObj = ThisDrawing.Utility
  ' Определение сплайна
  utilObj.CreateTypedArray startTan, vbDouble, 0.5, 0.5, 0
  utilObj.CreateTypedArray endTan, vbDouble, 0.5, 0.5, 0
  utilObj.CreateTypedArray fitPoints, vbDouble, 0, 0, 0, 5, 5, 0, 10, 0, 0
  noOfPoints = 3
  Set splineObj = ThisDrawing.ModelSpace.AddSpline(fitPoints, startTan, endTan)
  ZoomAll
End Sub

Интерпретация variant-массивов

Передаваемая AutoCAD ActiveX Automation информация массива возвращается как тип Variant, если типы данных элементов массива известны. Иначе применяем функции VarType Typename. Для перебора элементов массива удобен метод For Each. Пример вычисления расстояния между двумя точками введенными пользователем:

Sub CalculateDistance()
  Dim point1 As Variant,point2 As Variant
  ' Запрос на ввод координат
  point1 = ThisDrawing.Utility.GetPoint (, vbCrLf & "1-ая точка: ")
  point2 = ThisDrawing.Utility.GetPoint (point1, vbCrLf & "2-ая: ")
  Dim x As Double, y As Double, z As Double
  Dim dist As Double
  x = point1(0) - point2(0)
  y = point1(1) - point2(1)
  z = point1(2) - point2(2)
  dist = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
  MsgBox "Расстояние между точками: " & dist
End Sub

Использование других языков программирования

Чтобы использовать приведенные примеры не в VBA а в VB следует, во-первых, сослаться на библиотеку типов, во-вторых заменить все ссылки ThisDrawing Для этого определить переменную для приложения AutoCAD (myApp) и для активного документа (myDoc). Если AutoCAD запущен, метод GetObject возвращает объект AutoCAD Application. Если AutoCAD не запущен, то вызывается обработчик ошибок. Затем метод CreateObject пытается создать объект AutoCAD Application, как в следующем примере:

Sub ConnectToAcad()
  Dim acadApp As AcadApplication
  On Error Resume Next
  Set acadApp = GetObject(, "AutoCAD.Application")
    If Err Then
      Err.Clear
      Set acadApp = CreateObject("AutoCAD.Application")
    If Err Then
      MsgBox Err.Description
      Exit Sub
    End If
  MsgBox "Запушен " + acadApp.Name + " версии " + acadApp.Version
End Sub
' Далее установить ссылку на Document object в приложении AutoCAD
Dim acadDoc as AcadDocument
Set acadDoc = acadApp.ActiveDocument

Здесь уже используем acadDoc-переменную для ссылки на текущий рисунок AutoCAD. Если запущены несколько сеансов, AutoCAD-функция GetObject возвращает первое вхождение из Windows Running Object Table (ROT) .

Следующий пример демонстрирует создание линии в VB и VBA

Sub AddLineVBA()
  Dim lineObj As AcadLine
  Dim startPoint(0 To 2) As Double,endPoint(0 To 2) As Double
  ' Определим начальные и конечные координаты линии
  startPoint(0) = 1: startPoint(1) = 1: startPoint(2) = 0
  endPoint(0) = 5: endPoint(1) = 5: endPoint(2) = 0
  Set lineObj = ThisDrawing.ModelSpace.AddLine (startPoint, endPoint)
  ZoomExtents
End Sub

Sub AddLineVB()
  On Error Resume Next
  ' Подключение к приложению AutoCAD
  Dim acadApp As AcadApplication
  Set acadApp = GetObject (, "AutoCAD.Application")
  If Err Then
    Err.Clear
    Set acadApp = CreateObject ("AutoCAD.Application")
  If Err Then
    MsgBox Err.Description
    Exit Sub
  End If
  ' Подключение к рисунку AutoCAD
  Dim acadDoc As AcadDocument
  Set acadDoc = acadApp.ActiveDocument
  Dim lineObj As AcadLine
  Dim startPoint(0 To 2) As Double
  Dim endPoint(0 To 2) As Double
  startPoint(0) = 1: startPoint(1) = 1: startPoint(2) = 0
  endPoint(0) = 5: endPoint(1) = 5: endPoint(2) = 0
  Set lineObj = acadDoc.ModelSpace.AddLine (startPoint, endPoint)
  ZoomExtents
End Sub

Управление окружением AutoCAD

Открытие, сохранение и закрытие чертежа

Коллекция Documents и объект Document обеспечивают доступ к файловым функциям. Для этого следует использовать один из методов Add, Close, Save, SaveAs, Import, Export. Пример открытия рисунка:

Sub OpenDrawing()
  Dim dwgName As String
  dwgName = "c:Program Filesacad2002samplecampus.dwg"
  If Dir(dwgName) <> "" Then
     ThisDrawing.Application.Documents.Open dwgName
  Else
     MsgBox "Файл " & dwgName & " не существует."
  End If
End Sub

Пример создания чертежа:

Sub NewDrawing()
  Dim docObj As AcadDocument
  Set docObj = ThisDrawing.Application.Documents.Add
End Sub

Пример сохранения рисунка:

Sub SaveActiveDrawing()
  ' Сохранить рисунок с текущим именем
  ThisDrawing.Save
  ' А теперь с новым именем
  ThisDrawing.SaveAs "MyDrawing.dwg"
End Sub

Проверка были ли в рисунке какие-то изменения с момента последнего сохранения

Sub TestIfSaved()
  If Not (ThisDrawing.Saved) Then
     If MsgBox("Сохранить изменения?", vbYesNo) = vbYes Then ThisDrawing.Save
  End If
End Sub

Установка собственных предпочтений

Доступ к объекту Preferences

Dim acadPref as AcadPreferences
Set acadPref = ThisDrawing.Application.Preferences

После чего можно получить доступ к любому объекту Preference (предпочтений) пользуясь свойствами Display, Drafting, Files, OpenSave, Output, Profile, Selection, System, и User properties. Например, сменить размер перекрестия:

acadPref.Display.CursorSize = 100

Объект database preferences включает все настройки, которые сохраняются вместе с текущим рисунком.

Управление окном приложения

Пример смены размера и положения окна, минимизация и увеличение до максимума:

Sub PositionApplicationWindow()
  ThisDrawing.Application.WindowTop = 0
  ThisDrawing.Application.WindowLeft = 0
  ThisDrawing.Application.width = 400
  ThisDrawing.Application.height = 400
  ThisDrawing.Application.WindowState = acMax
  ThisDrawing.Application.WindowState = acMin
End Sub

Проверка состояния окна:

Sub CurrentWindowState()
  Dim CurrWindowState As Integer
  Dim msg As String
  CurrWindowState = ThisDrawing.Application.WindowState
  msg = Choose(CurrWindowState, "normal", "minimized", "maximized")
  MsgBox "Окно приложения" + msg
End Sub

Сделать окно невидимым:

ThisDrawing.Application.Visible = False

Управление окном рисунка

Аналогично окну приложения можно менять размеры и подчиненного окна — чертежа, как например:

Sub CurrentWindowState()
  Dim CurrWindowState As Integer
  Dim msg As String
  ThisDrawing.Width = 400
  ThisDrawing.Height = 400
  ThisDrawing.WindowState = acMin
  ThisDrawing.WindowState = acMax
  CurrWindowState = ThisDrawing.WindowState
  msg = Choose(CurrWindowState, "normal", "minimized", "maximized")
  MsgBox "Окно документа " + msg
End Sub

Использование zoom

Виды — это особые комбинации расположения, масштаба и ориентации рисунка. Команда zoom не меняет размер рисунка, она влияет только на размер его отображения на экране. AutoCAD предлагает несколько путей «зуммирования» по указанному окну, вписать рисунок в окно, указать масштаб вручную. Для «зуммирования» с указанием границ используются методы ZoomWindow или ZoomPickWindow Первый из них позволяет все сделать чисто программно, второй требует ввода границ окна от пользователя. Пример:

Sub ZoomWindow()
  MsgBox "Увеличение в пределах:" & vbCrLf & "1.3, 7.8, 0" & vbCrLf & "13.7, -2.6, 0"
  Dim point1(0 To 2) As Double
  Dim point2(0 To 2) As Double
  point1(0) = 1.3: point1(1) = 7.8: point1(2) = 0
  point2(0) = 13.7: point2(1) = -2.6: point2(2) = 0
  ThisDrawing.Application.ZoomWindow point1, point2
  MsgBox "А теперь ZoomPickWindow"
  ThisDrawing.Application.ZoomPickWindow
End Sub

Урок 8. Программирование на VBA

1.          Введение.
Обзор команд. Объектная модель

2.          Доступ к иерархии объектов. Коллекции, свойства и
методы

3.          Управление окружением AutoCAD

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

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

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

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

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

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

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

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

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

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

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

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

16.       Упражнение

Введение

Интерфейс AutoCAD ActiveX/VBA дает некотрые преимущества по сравнению
с другими методами создания приложений AutoCAD:

1.     
Высокая скорость выполнения процесса, так как в отличие
от AutoLISP-приложений выполнение команд происходит внутри процесса;

2.     
Простота использования, обусловленная простотой языка
программирования;

3.     
Большие возможности межпрограмного обмена, так как VBA
и ActiveX разрабатывались для взаимодействия с другими Windows-приложениями.

Понятие внедренных и глобальных проектов vba

Приложение Autocad VBA представляет собой набор программных
модулей, модулей классов и форм. Пороект может быть сохранен как в рисунке
(внедренный), так и во внешнем файле. Внедренный проект автоматически
загружается при открытии рисунка. Ограничение внедренных проектов в том,
например, что они не могут закрыть рисунок, внутри которого находятся. Глобальные
проекты в этом плане более гибки, при этом однако пользователь должен знать где
расположен файл в котором хранятся макросы. Глобальный проект проще передавать
другим пользователям и в нем удобно хранить общие макросы. В любой момент могут
быть использованы оба типа проектов. На уровне двоичного кода проект Autocad
VBA не совместим с проектом Visual Basic, однако обмен формами, модулями и
классами можно произвоидить через экспорт- импорт. (Команды IMPORT
и EXPORT VBA).

Загрузка существующего проекта

При загрузке проекта все глобальные процедуры, называемые
так же макросами, становятся доступными для использования. Загрузить проект
можно через VBA-менеджер или с командной строки VBALOAD. Кроме того
автокад грузит автоматически проект с именем acad.dvb, который может найти в
путях файлов поддержки. При загрузке проекта может появиться предупреждение,
что он содержит макросы, а значит может содержать и вирусы. Выгрузка проекта
командной VBAUNLOAD приводит к
высвобождению памяти ранее занятой проектом. Внедрить проект в рисунок можно с
помощью VBA-менеджера, он же позволяет извлечь проект из рисунка, при этом
предлагая сохранить его в отдельном файле. Чтобы среда разработки VBA
автоматически грузилась с автокадом, в файл acad.arx
нужно внести строку acadvba.arx.

Определение компонентов проекта

Проект может состоять из различных компонентов:

·        
объекты;

·        
формы;

·        
стандартные модули;

·        
модули класса;

·        
ссылки.

Добавить компонент можно через меню Insert,
компоненты так же можно импортировать из файлов (.frm, .bas, .cls).

Обзор команд vba autocad

VBAIDE — открывает
окно VBA IDE, позволяющее редактировать, запускать и отлаживать программы.

VBALOAD —
загружает проект.

VBARUN — запускает
макрос на выполнение.

VBAUNLOAD — выгружает
проект, освобождая память.

VBAMAN — показывает
окно менеджера VBA.

VBASTMT —
позволяет выполнить команду VBA в командной строке AutoCAD.

Основные понятия объектной модели AutoCAD

Все объекты Автокад организованы в виде иерархической
структуры. Корнем дерева является объект Application.

Через объект Application
можно получить доступ к следующим объектам:

Preferences;

Documents;

MenuBar;

MenuGroups;

Через объект Preferences можно получить доступ к
следующим объектам

PreferencesDisplay;

PreferencesDrafting;

PreferencesFiles;

PreferencesOpenSave;

PreferencesOutput;

PreferencesProfiles;

PreferencesSelection;

PreferencesSystem;

PreferencesUser.

Через объект Documents можно получить доступ к
объекту Document а через него к
большинству других объектов и коллекций:

Blocks (блоки)

Dictionaries (словари)

DimStyles (размерные стили)

Groups (группы)

Layers (слои)

Layouts ()

Linetypes (типы линий)

PlotConfigurations (настройки плоттеров)

RegisteredApplications (зарегистрированные приложения)

SelectionSets (наборы)

TextStyles (стили текста)

UserCoordinateSystems
(системы координат определенные пользователем)

Views (виды)

Viewports
(видовые экраны)

DatabasePreferences ()

Plot (печать)

Utility (служебные программы)

ModelSpace
(пространство модели)

PaperSpace
(пространство листа)

В двух последних расположены объекты AutoCAD, видимые на рисунке:

3DFace

3DPoly

3DSolid

Arc

Attribute

AttributeReference

BlockReference

Circle

Dim3PointAngular

DimAligned

DimAngular

DimDiametric

DimOrdinate

DimRadial

DimRotated

Ellipse

ExternalReference

Hatch

Leader

LWPolyline

Line

MInsertBlock

MLine

MText

Point

PolyfaceMesh

Polyline

PolygonMesh

RasterImage

Ray

Region

Shape

Solid

Spline

Text

Tolerance

Trace

Xline

2.    Доступ
к иерархии объектов. Коллекции, свойства и методы

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

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

ThisDrawing.Save 

Ссылка на объекты в иерархии объектов

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

Sub Test()

  Dim startPoint(0 To 2) As Double, endPoint(0 To 2) As Double

  Dim LineObj As AcadLine

  startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0

  endPoint(0) = 30: endPoint(1) = 20: endPoint(2) = 0

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

End Sub

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

Dim moSpace As AcadModelSpace

Set moSpace = ThisDrawing.ModelSpace

В примере добавляем линию в пространство модели, используя
эту переменную:

Dim startPoint(0 To 2) As Double, endPoint(0 To 2) As Double

Dim LineObj as AcadLine

startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0

endPoint(0) = 30: endPoint(1) = 20: endPoint(2) = 0

Set LineObj = moSpace.AddLine(startPoint,endPoint)

Корневой объект Application
расположен в иерархии выше объекта Document.
Выше показано, что объект ThisDrawing
обеспечивает доступ к объекту Document. А
у объекта Document есть свойство Application, которое и является ссылкой на
объект Application. Пример
обращения:

ThisDrawing.Application.Update

Коллекции объектов

Объект Collection
— является предопределенным объектом содержащим все вхождения подобных
объектов. Существуют следующие объекты коллекции:

·        
Documents
— включает все открытые в текущей сессии документы

·        
ModelSpace
— включает все графические объекты (entities — примитивы) пространства модели

·        
PaperSpace
— включает все графические объекты пространства активного листа

·        
Block Object
— включает все указанные определения блоков

·        
Blocks
— включает все блочные ссылки рисунка

·        
Dictionaries
— включает все словари (Dictionaries) рисунка

·        
DimStyles
— включает все размерные стили рисунка

·        
Groups
— включает все группы рисунка

·        
Groups
— включает все гиперссылки рисунка

·        
Layers
— включает все слои рисунка

·        
Layouts
— включает все листы рисунка

·        
Linetypes
— включает все типы линий рисунка

·        
MenuBar
— включает все отображаемые AutoCADом меню

·        
MenuGroups
— включает все меню и панели инструментов

·        
RegisteredApplications
— включает все зарегистрированные приложения

·        
SelectionSets
— включает все наборы рисунка

·        
TextStyles
— включает все стили текста рисунка

·        
UCSs
— включает все пользовательсткие системы координат рисунка

·        
Views
— включает все Виды рисунка

·        
Viewports
— включает все видовые экраны рисунка

Доступ к коллекции

Большинство коллекций доступны через объект Document, т.к. он содержит
свойства для каждой из коллекций. Следующий код устанавливает сслыку объектной
переменной на коллекцию Layers:

Dim layerCollection as AcadLayers

Set layerCollection = ThisDrawing.Layers

Коллекции Documents, MenuBar и MenuGroups
доступны через объект Application.
Он содержит свойства для каждой из этих коллекций. Следующий пример
определяет объектную переменную и создает ссылку через нее на коллекцию:

Dim MenuGroupsCollection as AcadMenuGroups

Set MenuGroupsCollection = ThisDrawing.Application.MenuGroups

Добавление нового элемента  коллекции

Следующий пример создает слой и добавляет его в коллекцию:

Dim newLayer as AcadLayer

Set newLayer = ThisDrawing.Layers.Add("MyNewLayer")

Перебор членов коллекции

Для выбора нужного члена коллекции используется метод Item. В качестве параметра ему передается
номер (Index) объекта в
коллекции либо его символьный идентификатор. Пример демонстрирует перебор всех
слоев с отображеним их имен

Sub IterateLayer()

  On Error Resume Next

  Dim I As Integer

  Dim msg As String

  msg = ""

  For I = 0 To ThisDrawing.Layers.count - 1

    msg = msg + ThisDrawing.Layers.Item(I).Name + vbCrLf

  Next

  MsgBox msg

End Sub

Пример поиска слоя с именем ABC:

Sub FindLayerABC()

  On Error Resume Next

  Dim ABCLayer As AcadLayer

  Set ABCLayer = ThisDrawing.Layers.Item("ABC")

  If Err <> 0 Then

    MsgBox "Слой 'ABC' не существует"

  End If

End Sub

Примечание

Не следует использовать методы редактирования примитивов (Copy, Array,
Mirror и др.) на любом
объекте который одновременно перебирается с помощью механизма For
Each. В случае необходимости нужно закончить перебор, создать
временный массив эквивалентный коллекции и в этом массиве выполнить
редактирование.

Удаление члена коллекции

Пример удаления слоя:

Dim ABCLayer as AcadLayer

Set ABCLayer = ThisDrawing.Layers.Item("ABC")

ABCLayer.Delete

Удаленный объект восстановлению не подлежит.

Понятие свойств и методов

Каждый объект обладает связанными с ним свойствами и
методами. Свойства описывают некоторые характеристики присущие объекту, а
методы позволяют выполнять действия над объектами, в частности, менять и читать
свойства. Например, объект окружность имеет свойство Центр,
которое представляет трехмерную координату центра окружности. Чтобы сменить
свойство достаточно задать ему другое значение. Окружность как целое имеет
метод Offset, который создает
новый объект на указанном смещении от существующего. Полный перечень свойств и
методов есть в ActiveX and VBA Reference.

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

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

Библиотеки типов

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

Получение первого примитива из базы данных рисунка

Sub FindFirstEntity()

  On Error Resume Next

  Dim entity As AcadEntity

  If ThisDrawing.ModelSpace.count <> 0 Then

    Set entity = ThisDrawing.ModelSpace.Item(0)

    MsgBox entity.ObjectName + " первый примитив в пространстве модели."

  Else

    MsgBox "Нет ни одного объекта в пространстве модели."

  End If

End Sub

Применение variant в методах и свойствах

Для передачи массива данных AutoCAD использует тип Variant
который может принимать данные любого типа за исключением строк фиксированной
длины и типов данных, определяемых пользователем. Может также принимать
значения Empty, Error, Nothing, NULL. Чтобы узнать какой именно тип данных
хранятся в переменной типа Variant, нужно обратиться к функции VarType или TypeName.

Тип данных Variant
используется для передачи массива данных из/в AutoCAD ActiveX
Automation. В AutoCAD VBA-входные массивы автоматически
преобразуются в тип Variant. Однако c
выходными массивами все не так просто. Метод CreateTypedArray
преобразует массив в Variant,
содержащий «смесь» из Integer, Double
и т.д. Эту «смесь» можно передать в любой метод или любое свойство AutoCAD,
которые принимают массив чисел как Variant.

В примере преобразуются три массива координат сплайна с передачей
их методу AddSpline.

Sub CreateSplineUsingTypedArray()

  Dim splineObj As AcadSpline

  Dim startTan As Variant, endTan As Variant, fitPoints As Variant

  Dim noOfPoints As Integer

  Dim utilObj As Object

  Set utilObj = ThisDrawing.Utility

  ' Определение сплайна

  utilObj.CreateTypedArray startTan, vbDouble, 0.5, 0.5, 0

  utilObj.CreateTypedArray endTan, vbDouble, 0.5, 0.5, 0

  utilObj.CreateTypedArray fitPoints, vbDouble, 0, 0, 0, 5, 5, 0, 10, 0, 0

  noOfPoints = 3

  Set splineObj = ThisDrawing.ModelSpace.AddSpline(fitPoints, startTan, endTan)

  ZoomAll

End Sub

Интерпретация variant-массивов

Передаваемая AutoCAD ActiveX Automation информация массива
возвращается как тип Variant, если типы
данных элементов массива известны. Иначе применяем функции VarType
Typename. Для перебора элементов массива удобен метод For Each. Пример вычисления расстояния между
двумя точками введенными пользователем:

Sub CalculateDistance()

  Dim point1 As Variant,point2 As Variant

  ' Запрос на ввод координат

  point1 = ThisDrawing.Utility.GetPoint (, vbCrLf & "1-ая точка: ")

  point2 = ThisDrawing.Utility.GetPoint (point1, vbCrLf & "2-ая: ")

  Dim x As Double, y As Double, z As Double

  Dim dist As Double

  x = point1(0) - point2(0)

  y = point1(1) - point2(1)

  z = point1(2) - point2(2)

  dist = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))

  MsgBox "Расстояние между точками: " & dist

End Sub

Использование других языков программирования

Чтобы использовать приведенные примеры не в VBA а в VB
следует, во-первых, сослаться на библиотеку типов, во-вторых заменить все
ссылки ThisDrawing Для этого
определить переменную для приложения AutoCAD (myApp) и для активного документа (myDoc). Если AutoCAD запущен,
метод GetObject возвращает
объект AutoCAD Application. Если AutoCAD не запущен, то вызывается
обработчик ошибок. Затем метод CreateObject
пытается создать объект AutoCAD Application, как в следующем примере:

Sub ConnectToAcad()

  Dim acadApp As AcadApplication

  On Error Resume Next

  Set acadApp = GetObject(, "AutoCAD.Application")

    If Err Then

      Err.Clear

      Set acadApp = CreateObject("AutoCAD.Application")

    If Err Then

      MsgBox Err.Description

      Exit Sub

    End If

  MsgBox "Запушен " + acadApp.Name + " версии " + acadApp.Version

End Sub

' Далее установить ссылку на Document object в приложении AutoCAD

Dim acadDoc as AcadDocument

Set acadDoc = acadApp.ActiveDocument

Здесь уже используем acadDoc-переменную
для ссылки на текущий рисунок AutoCAD.
Если запущены несколько сеансов, AutoCAD-функция GetObject
возвращает первое вхождение из Windows
Running Object Table (ROT).

Следующий пример демонстрирует создание линии в VB и VBA

Sub AddLineVBA()

  Dim lineObj As AcadLine

  Dim startPoint(0 To 2) As Double,endPoint(0 To 2) As Double

  ' Определим начальные и конечные координаты линии

  startPoint(0) = 1: startPoint(1) = 1: startPoint(2) = 0

  endPoint(0) = 5: endPoint(1) = 5: endPoint(2) = 0

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

  ZoomExtents

End Sub

Sub AddLineVB()

  On Error Resume Next

  ' Подключение к приложению AutoCAD

  Dim acadApp As AcadApplication

  Set acadApp = GetObject (, "AutoCAD.Application")

  If Err Then

    Err.Clear

    Set acadApp = CreateObject ("AutoCAD.Application")

  If Err Then

    MsgBox Err.Description

    Exit Sub

  End If

  ' Подключение к рисунку AutoCAD

  Dim acadDoc As AcadDocument

  Set acadDoc = acadApp.ActiveDocument

  Dim lineObj As AcadLine

  Dim startPoint(0 To 2) As Double

  Dim endPoint(0 To 2) As Double

  startPoint(0) = 1: startPoint(1) = 1: startPoint(2) = 0

  endPoint(0) = 5: endPoint(1) = 5: endPoint(2) = 0

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

  ZoomExtents

End Sub

3.    Управление
окружением AutoCAD

Открытие, сохранение и закрытие чертежа

Коллекция Documents и объект Document обеспечивают доступ к
файловым функциям. Для этого следует использовать один из методов Add,
Close, Save, SaveAs, Import, Export. Пример открытия рисунка:

Sub OpenDrawing()

  Dim dwgName As String

  dwgName = "c:Program Filesacad2002samplecampus.dwg"

  If Dir(dwgName) <> "" Then

     ThisDrawing.Application.Documents.Open dwgName

  Else

     MsgBox "Файл " & dwgName & " не существует."

  End If

End Sub

Пример создания чертежа:

Sub NewDrawing()

  Dim docObj As AcadDocument

  Set docObj = ThisDrawing.Application.Documents.Add

End Sub

Пример сохранения рисунка:

Sub SaveActiveDrawing()

  ' Сохранить рисунок с текущим именем

  ThisDrawing.Save

  ' А теперь с новым именем

  ThisDrawing.SaveAs "MyDrawing.dwg"

End Sub

Проверка были ли в рисунке какие-то изменения с момента
последнего сохранения

Sub TestIfSaved()

  If Not (ThisDrawing.Saved) Then

     If MsgBox("Сохранить изменения?", vbYesNo) = vbYes Then ThisDrawing.Save

  End If

End Sub

Установка собственных предпочтений

Доступ к объекту Preferences

Dim acadPref as AcadPreferences

Set acadPref = ThisDrawing.Application.Preferences

После чего можно получить доступ к
любому объекту Preference (предпочтений) пользуясь свойствами Display, Drafting, Files, OpenSave, Output, Profile, Selection, System, и User properties. Например, сменить размер перекрестия:

acadPref.Display.CursorSize = 100

Объект database
preferences включает все настройки, которые сохраняются всместе с
текущим рисунком.

Управление окном приложения

Пример смены размера и положения окна, минимизация и
увеличение до максимума:

Sub PositionApplicationWindow()

  ThisDrawing.Application.WindowTop = 0

  ThisDrawing.Application.WindowLeft = 0

  ThisDrawing.Application.width = 400

  ThisDrawing.Application.height = 400

  ThisDrawing.Application.WindowState = acMax

  ThisDrawing.Application.WindowState = acMin

End Sub

Проверка состояния окна:

Sub CurrentWindowState()

  Dim CurrWindowState As Integer

  Dim msg As String

  CurrWindowState = ThisDrawing.Application.WindowState

  msg = Choose(CurrWindowState, "normal", "minimized", "maximized")

  MsgBox "Окно приложения" + msg

End Sub

Сделать окно невидимым:

ThisDrawing.Application.Visible = False

Управление окном рисунка

Аналогично окну приложения можно менять размеры и
подчиненного окна — чертежа, как например:

Sub CurrentWindowState()

  Dim CurrWindowState As Integer

  Dim msg As String

  ThisDrawing.Width = 400

  ThisDrawing.Height = 400

  ThisDrawing.WindowState = acMin

  ThisDrawing.WindowState = acMax

  CurrWindowState = ThisDrawing.WindowState

  msg = Choose(CurrWindowState, "normal", "minimized", "maximized")

  MsgBox "Окно документа " + msg

End Sub

Использование zoom.

Виды — это особые комбинации расположения, масштаба и
ориентации рисунка. Команда zoom
не меняет размер рисунка, она влияет только на размер его отображения на
экране. AutoCAD
предлагает несколько путей «зуммирования» по указанному окну, вписать
рисунок в окно, указать масштаб вручную. Для «зуммирования» с
указанием границ используются методы ZoomWindow
или ZoomPickWindow Первый из
них позволяет все сделать чисто программно, второй требует ввода границ окна от
пользователя. Пример:

Sub ZoomWindow()

  MsgBox "Увеличение в пределах:" & vbCrLf & "1.3, 7.8, 0" & vbCrLf & "13.7, -2.6, 0"

  Dim point1(0 To 2) As Double

  Dim point2(0 To 2) As Double

  point1(0) = 1.3: point1(1) = 7.8: point1(2) = 0

  point2(0) = 13.7: point2(1) = -2.6: point2(2) = 0

  ThisDrawing.Application.ZoomWindow point1, point2

  MsgBox "А теперь ZoomPickWindow"

  ThisDrawing.Application.ZoomPickWindow

End Sub

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

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

·        
Относительно границ рисунка

·        
Относительно текущего вида

·        
Относительно единиц вычерчивания на листе

При этом следует просто ввести значение. Например, 2 для
увеличения в 2 раза и .5 для уменьшения в два раза.

Для масштабирования вида используется метод ZoomScaled, на входе он
принимает два параметра масштаб и тип масштаба. Типы масштаба задаются константами:
acZoomScaledAbsolute,
acZoomScaledRelative, acZoomScaledRelativePSpace.

Sub ZoomScaled()

   MsgBox "Масштабирование:" & vbCrLf & "Тип: acZoomScaledRelative" & vbCrLf & "Фактор: 2"

   Dim scalefactor As Double

   Dim scaletype As Integer

   scalefactor = 2

   scaletype = acZoomScaledRelative

   ThisDrawing.Application.ZoomScaled scalefactor, scaletype

End Sub

Центрирование

Указанную точку рисунка можно поместить по центру экрана
методом ZoomCenter как в
следующем примере:

Sub ZoomCenter()

  MsgBox "Центрировать:" & vbCrLf & "Центр: 3,3,0" & vbCrLf &  "Увеличение: 10"

  Dim Center(0 To 2) As Double

  Dim magnification As Double

  Center(0) = 3: Center(1) = 3: Center(2) = 0: magnification = 10

  ThisDrawing.Application.ZoomCenter Center, magnification

End Sub

Показ границ (limits) и протяженности (extents) рисунка

Для отображения границ рисунка или границ объектов
используется методы ZoomAll, ZoomExtents,
ZoomPrevious. Первый из них показывает рисунок полностью. Если
границы объектов выходят за пределы границ рисунка, то показывается по границам
объектов и наооборот.

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

ZoomAll аналогично
ZoomExtents но при этом
включается еще и зона границ. Если зона границ окажется заполнена мало все окно
может оказаться пустым. Наиболее удобным вариантом просмотра всего рисунка является
метод ZoomExtents.

Sub ZoomAll()

  MsgBox "ZoomAll"

  ThisDrawing.Application.ZoomAll

  MsgBox "ZoomExtents"

  ThisDrawing.Application.ZoomExtents

End Sub

Использование именованных видов

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

Sub AddView()

  Dim viewObj As AcadView

  Set viewObj = ThisDrawing.Views.Add("View1")

  msgbox "А теперь удалить вид"

  ThisDrawing.Views("View1").Delete

End Sub

Видовой экран можно разбивать на части методами: acViewport2Horizontal, acViewport2Vertical,
acViewport3Left, acViewport3Right, acViewport3Horizontal, acViewport3Vertical, acViewport3Above,
acViewport3Below, acViewport4.

Sub SplitAViewport()

  Dim vportObj As AcadViewport

  Set vportObj = ThisDrawing.Viewports.Add("TEST_VIEWPORT")

  vportObj.Split acViewport2Horizontal

  ThisDrawing.ActiveViewport = vportObj

End Sub

Пример разбивки видовых экранов и перебор открытых окон:

Sub IteratingViewportWindows()

  Dim vportObj As AcadViewport

  Set vportObj = ThisDrawing.Viewports.Add("TEST_VIEWPORT")

  ThisDrawing.ActiveViewport = vportObj ' сделать активным

  vportObj.Split acViewport4 ' Разбить на 4 окна

  ' Перебор видовых экранов, подсвечивая каждый

  ' и показывая углы для каждого

  Dim vport As AcadViewport

  Dim LLCorner As Variant,URCorner As Variant

  For Each vport In ThisDrawing.Viewports

    ThisDrawing.ActiveViewport = vport

    LLCorner = vport.LowerLeftCorner

    URCorner = vport.UpperRightCorner

    MsgBox "Видовой экран: " & vport.Name & " активнен." & _

    vbCrLf & "Нижний левый угол: " & _

    LLCorner(0) & ", " & LLCorner(1) & _

    vbCrLf & "Верхний правый: " & URCorner(0) & ", " & URCorner(1)

  Next vport

End Sub

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

Sub UpdateDisplay()

  Dim circleObj As AcadCircle

  Dim center(0 To 2) As Double

  Dim radius As Double

  center(0) = 1: center(1) = 1: center(2) = 0: radius = 1

  Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)

  circleObj.Color = acRed

  circleObj.Update

End Sub

Переустановка активных объектов

Изменение большинства активных объектов (слоев, типов линий)
вступает в силу немедленно, однако некоторые активные объекты требуют повторной
установки. (это стили текста, видовые экраны и ПСК). Для их переустановки
требуется установка свойств ActiveTextStyle,
ActiveUCS, ActiveViewport.

Sub ResetActiveViewport()

' переключим сетку

  ThisDrawing.ActiveViewport.GridOn = Not (ThisDrawing.ActiveViewport.GridOn)

  ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport

End Sub

Установка и считывание системных переменных

У объекта Document есть два метода SetVariable и GetVariable. Пример:

ThisDrawing.SetVariable
"TEXTFILL", 1

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

AutoCAD позволяет вычерчивать объекты с точно заданными
характеристиками, не прибегая при этом к утомительным вычислениям. Ограничением
VBA для Autocad  является то что через
VBA нельзя установить изометрическую сетку и привязку, установить объектную
привязку, указать измеряемые отрезки на объекте или поделить объект на
сегменты.

Регулировка привязки и выравнивания сетки

Изменение угла и базовой точки. В данном примере базовая
точка устанавливается равной 1,1 и угол наклона сетки 30 градусов:

Sub ChangeSnapBasePoint()

  ' Включим сетку

  ThisDrawing.ActiveViewport.GridOn = True

  ' Сменим базовую точку 1,1

  Dim newBasePoint(0 To 1) As Double

  newBasePoint(0) = 1: newBasePoint(1) = 1

  ThisDrawing.ActiveViewport.SnapBasePoint = newBasePoint

  ' Сменим угол для привязки на 30 градусов (.575 радиан)

  Dim rotationAngle As Double

  rotationAngle = 0.575

  ThisDrawing.ActiveViewport.SnapRotationAngle = rotationAngle

  ' переустановим видовой экран

  ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport

End Sub

Включение режима орто (нужен для простой отрисовки перпендикуляров)

ThisDrawing.ActiveViewport.OrthoOn
= True

Построение конструкционных линий (в обе стороны бесконечных)

Sub AddXLine()

  Dim xlineObj As AcadXline

  Dim basePoint(0 To 2) As Double

  Dim directionVec(0 To 2) As Double

  basePoint(0) = 2#: basePoint(1) = 2#: basePoint(2) = 0#

  directionVec(0) = 1#: directionVec(1) = 1#: directionVec(2) = 0#

  Set xlineObj = ThisDrawing.ModelSpace.AddXLine (basePoint, directionVec)

  ThisDrawing.Application.ZoomAll

End Sub

Опрос конструкционных линий

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

Dim BPoint As Variant

Dim Vector As Variant

Set BPoint = xlineObj.basePoint

Set Vector = xlineObj.DirectionVector

СОЗДАНИЕ, ОПРОС И РЕДАКТИРОВАНИЕ ЛУЧЕЙ

Sub EditRay()

  Dim rayObj As AcadRay

  Dim basePoint(0 To 2) As Double,secondPoint(0 To 2) As Double

  ' Определим луч

  basePoint(0) = 3#: basePoint(1) = 3#: basePoint(2) = 0#

  secondPoint(0) = 4#: secondPoint(1) = 4#: secondPoint(2) = 0#

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

  Set rayObj = ThisDrawing.ModelSpace.AddRay (basePoint, secondPoint)

  ThisDrawing.Application.ZoomAll

  ' Получим состояние луча

  MsgBox "Базовая точка луча: " & rayObj.basePoint(0) & ", " & _

  rayObj.basePoint(1) & ", " & rayObj.basePoint(2) & vbCrLf & _

  "Направляющий вектор луча: " & rayObj.DirectionVector(0) & ", " & _

  rayObj.DirectionVector(1) & ", " & rayObj.DirectionVector(2)

  ' Изменим направляющий вектор луча

  Dim newVector(0 To 2) As Double

  newVector(0) = -1 : newVector(1) = 1 : newVector(2) = 0

  rayObj.DirectionVector = newVector

  ThisDrawing.Regen False

  MsgBox "Базовая точка луча: " & rayObj.basePoint(0) & ", " & _

  rayObj.basePoint(1) & ", " & rayObj.basePoint(2) & vbCrLf & _

  "Направляющий вектор луча: " & rayObj.DirectionVector(0) & ", " & _

  rayObj.DirectionVector(1) & ", " & rayObj.DirectionVector(2)

End Sub

Вычисления с использованием выражений

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

·        
Найти угол линии от оси X методом AngleFromXAxis

·        
Преобразовать угол из строки в вещественное
(двойной точности) методом AngleToReal

·        
Преобразовать угол из вещественного (двойной
точности) в строку методом AngleToString

·        
Преобразовать расстояние из строки в
вещественное (двойной точности) методом DistanceToReal

·        
Создать переменную типа Variant, содержащую
массив целых, с плавающей точкой двойной точности и т.д. методом CreateTypedArray

·        
Найти точку отложенную на заданном расстоянии и
под заданным углом методом PolarPoint

·        
Перевести точку в другую систему координат
методом TranslateCoordinates

·        
Найти расстояние между двумя точками методом GetDistance

Sub GetDistanceBetweenTwoPoints()

  Dim returnDist As Double

  returnDist = ThisDrawing.Utility.GetDistance (, "Выбери 2 точки.")

  MsgBox "Расстояние между точками: " & returnDist

End Sub

Подсчет площадей

Используя значение свойства Area,
определим площадь многоугольника, вершины которого указаны пользователем:

Sub CalculateDefinedArea()

  Dim p1 As Variant,p2 As Variant,p3 As Variant,p4 As Variant,p5 As Variant

  ' Получить точки от пользователя

  p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "1-ая точка: ")

  p2 = ThisDrawing.Utility.GetPoint(p1, vbCrLf & "2-ая точка: ")

  p3 = ThisDrawing.Utility.GetPoint(p2, vbCrLf & "3-ая точка: ")

  p4 = ThisDrawing.Utility.GetPoint(p3, vbCrLf & "4-ая точка: ")

  p5 = ThisDrawing.Utility.GetPoint(p4, vbCrLf & "5-ая точка: ")

  ' Создаем двумерную полилинию

  Dim polyObj As AcadLWPolyline

  Dim vertices(0 To 9) As Double

  vertices(0) = p1(0): vertices(1) = p1(1)

  vertices(2) = p2(0): vertices(3) = p2(1)

  vertices(4) = p3(0): vertices(5) = p3(1)

  vertices(6) = p4(0): vertices(7) = p4(1)

  vertices(8) = p5(0): vertices(9) = p5(1)

  Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline (vertices)

  polyObj.Closed = True

  ThisDrawing.Application.ZoomAll

  MsgBox "Площадь определенная точками " & polyObj.Area

End Sub

Получение ввода от пользователя

Объект Utility
может получать ввод от пользователя данных определенного типа, например метод GetString возвращает строку, GetPoint
возвращает значение типа Variant
и GetInteger возвращает
целое. Управление вводом пользователя можно осуществлять методом InitializeUserInput. Он позволяет проверять
пустой ввод (NULL), ввод
отрицательных значений. Метод GetString
принимает два параметра, если первый из них равен 0, то пробел сразу завершает
ввод, второй — строка подсказка.

Sub GetStringFromUser()

  Dim retVal As String

  retVal = ThisDrawing.Utility.GetString (1, vbCrLf & "Как вас зовут: ")

  MsgBox "Привет, " & retVal

End Sub

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

Sub GetPointsFromUser()

  Dim startPnt As Variant,endPnt As Variant

  Dim prompt1 As String,prompt2 As String

  prompt1 = vbCrLf & "Начальная точка линии: "

  prompt2 = vbCrLf & "Конечная точка линии: "

  startPnt = ThisDrawing.Utility.GetPoint(, prompt1)

  ' Используем ранее введенную точку как базовую

  endPnt = ThisDrawing.Utility.GetPoint(startPnt, prompt2)

  ThisDrawing.ModelSpace.AddLine startPnt, endPnt

  ThisDrawing.Application.ZoomAll

End Sub

Метод GetKeyword
принимает только один параметр, это ключевое слово Autocad и так же может
использовать вызова метода InitializeUserInput.

Sub KeyWord()

  Dim keyWord As String

  ThisDrawing.Utility.InitializeUserInput 1, "Line Circle Arc"

  keyWord = ThisDrawing.Utility.GetKeyword (vbCrLf & "Введите (Line/Circle/Arc): ")

  MsgBox keyWord

End Sub

Более дружественный для пользователя вариант выбирает один
из вариантов как выбор по умолчанию, осуществляющийся при нажатии Enter

Sub KeyWord2()

  Dim keyWord As String

  ThisDrawing.Utility.InitializeUserInput 0, "Line Circle Arc"

  keyWord = ThisDrawing.Utility.GetKeyword (vbCrLf & "Введите (Line/Circle/): ")

  If keyWord = "" Then keyWord = "Arc"

  MsgBox keyWord

End Sub

Управление вводом пользователя

Применение метода InitializeUserInput
позволяет определить ключевые слова или ограничить тип вводимых значений.
Данный метод может применяться совместно со следующими методами GetAngle,
GetCorner, GetDistance, GetInteger, GetKeyword, GetOrientation, GetPoint,
GetReal (но не с GetString,
в этом случае есть метод GetInput
для получения строкового значения).

Метод InitializeUserInput
принимает два параметра — первый битовое значение, определяющее опции ввода,
второй строковый — определяет допустимые ключевые слова.

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

Пример ввода положительного целого

Sub UserInput()

  ' Первый параметр (6) ограничивает ввод положительными целыми

  ' Второй список ключевых слов

  ThisDrawing.Utility.InitializeUserInput 6, "Big Small Regular"

  Dim promptStr As String

  promptStr = vbCrLf & "Размер (Big/Small/[Regular]):"

  ' Ввод ключевого слов в метод GetInteger вызовет ошибку

  ' чтобы позволить программе выполняться дальше

  ' установим обработчик ошибок

  On Error Resume Next

  ' Получить ввод от пользователя

  Dim returnInteger As Integer

  returnInteger = ThisDrawing.Utility.GetInteger(promptStr)

  ' Проверить нет ли ошибки, затем использовать GetInput для получения

  ' строки иначе значение returnInteger.

  If Err.Description = "User input is a keyword" Then

    Dim returnString As String

    returnString = ThisDrawing.Utility.GetInput()

    Err.Clear

  Else

    If returnInteger = 0 Then ' Нажат ENTER

       returnString = "Regular" ' значение по-умолчанию

    Else

       returnString = returnInteger ' введенное значение

    End If

  End If

  MsgBox returnString, , "Пример InitializeUserInput"

End Sub

Доступ к командной строке autocad

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

Следующий пример создает окружность с центром (2,2,0) и
радиусом 4.

Sub SendACommandToAutoCAD()

ThisDrawing.SendCommand "_Circle 2,2,0 4 "

ThisDrawing.SendCommand "_zoom a "

End Sub

Обратите внимание на пробел в конце каждой строки.

Если не открыт ни один документ

Несмотря на то, что Autocad всегда стартует с пустым или
открытым документом существует возможность закрыть все документы, при этом
главное меню сократится до 4-х пунктов (File,
View, Window, Help), а также пропадет командная строка. Интерфейс
ActiveX в данном случае позволяет выполнять только следующие действия

·        
Открыть документ

·        
Создать документ

·        
Импортировать документ

·        
Выйти из Autocad

Эти действия доступны для всей коллекции Documents,
кроме того методы и свойства данной коллекции ограничены набором методов и
свойств объекта Application.
Свойство Count коллекции Documents открыт ли хоть один документ.If Documents.Count > 0 Then
открыт как минимум один документ. Здесь важно также заметить, что объект ThisDrawing неопределен, если не открыт ни
один документ, поэтому попытка выполнить макрос с ThisDrawing
приведет к ошибке периода выполнения. Вместо этого используй функцию GetObject.

Импорт файлов других форматов

Метод Import
позволяет импортировать файлы форматов DXF,
SAT, BMP, PostScript. Он принимает три параметра: имя файла,
точку вставки и фактор масштабирования.

Экспорт в другие форматы

Метод Export
поддерживает следующие форматы: WMF, SAT,
EPS, DXF, DWF, BMP.
Он принимает три параметра: имя создаваемого файла, тип создаваемого файла и
набор экспортируемых объектов. При экспорте в WMF,
SAT или BMP должен
существовать непустой набор. В EPS
и DXF экспортируется весь
рисунок.

Пример эскпорта-импорта в DXF

Sub ImportingAndExporting()

  ' Созадим окружность, чтоб было что экспортировать

  Dim circleObj As AcadCircle

  Dim centerPt(0 To 2) As Double,radius As Double

  centerPt(0) = 2: centerPt(1) = 2: centerPt(2) = 0: radius = 1

  Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPt, radius)

  ThisDrawing.Application.ZoomExtents

  ' Создадим пустой набор

  Dim sset As AcadSelectionSet

  Set sset = ThisDrawing.SelectionSets.Add("NEWSSET")

  ' Экспорт в файл C:DXFExprt, если каталог не существует - ошибка

  Dim exportFile As String

  exportFile = "C:DXFExprt"

  ThisDrawing.Export exportFile, "DXF", sset

  ' Определим импорт

  Dim importFile As String

  Dim insertPoint(0 To 2) As Double

  Dim scalefactor As Double

  importFile = "C:DXFExprt.dxf"

  insertPoint(0) = 0: insertPoint(1) = 0: insertPoint(2) = 0: scalefactor = 2#

  ' Импортируем файл

  ThisDrawing.Import importFile, insertPoint, scalefactor

  ThisDrawing.Application.ZoomExtents

End Sub

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

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

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

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

·        
AddLine — создает линию по двум точкам;

·        
AddLightWeightPolyline — создает двумерную полилинию;

·        
AddMLine — создает мультилинию;

·        
AddPolyLine — создает двумерную или
трехмерную полилинию.

Стандартные линии и мультилини создаются в плоскости 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 мировой системы координат. Для их создания используется
один из следующих методов:

• AddArc — дуга через центр, радиус, начальная точка и конечный угол;
• AddCircle — окружность через центр и радиус;
• Addellipse — эллипс через центр, точку на главной оси и радиус кривизны;
• AddSpline – кривая.

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

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

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

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

• AddItem — добавляет один или более объектов в набор;
• Select — выбирает
  объекты и помещает в активный набор, можно выбрать все объекты, выбрать
  секущей или прямоугольной рамкой, последний созданый, из последнего
  созданного набора, окном или полигоном;
• SelectAtPoint — выбрать объекты проходящие через данную точку;
• SelectByPolygon — выбрать объекты полигоном;
• SelectOnScreen — запросить у пользователя указания объектов.

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

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

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

• RemoveItems — удаляет один или более объект из набора, но не из рисунка;
• Clear — очищает набор, не удаляя его;
• Erase — удаляет объекты из рисунка, очищая набор;
• Delete — удаляет набор, не трогая объекты.

Пример:

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

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

Объекты рисунка могут быть копированы, в том числе на
определенное смещение от оригинала. Можно так же создать зеркальное отображение
объекта относительно заданной линии. Объекты могут размножаться через
прямоугольный или окурглый шаблон. Нельзя только использовть эти методы
одновременно с перебором элементов коллекции, сначала следует завершить
перебор. Для копирования единичного объекта метод 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
масштабирует объект пропорционально по всем осям. Он требует укзания базовой
точки и фактора масштабирования. Базовая точка как обычно переменная типа
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 отбрасывает информацию
сплайна, при присоединении его к другой полилинии. Когда объединение завершено,
можно задать новый сплайн для результата.

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

• Closed — замыкает или разрывает полилинию;
• Coordinates — задает координаты каждой вершины;
• AddVertex — добавляет вершину в LWPolyLine;
• SetBulge — задает скос для семента по его индексу;
• SetWidth — задает ширину в начале и конце сегмента по его индексу.

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

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 пригодится в последнем случае.
Свойства и методы меняющие характеристи сплайна

• Closed — разрывает или замыкает сплайн;
• ControlPoints — задает контрольные точки;
• EndTangent — задает конечную касательную как направляющий вектор;
• FitPoints — задает все точки размещения сплайна;
• FitTolerance — переразмещает сплайн по существующим точкам с новым значением
  Tolerance;
• Knots — задает узловые векторы сплайна;
• StartTangent — задает начальную касательную сплайна;
• AddFitPoint — добавляет точку размещения сплайна с данным индексом;
• DeleteFitPoint — удаляет точку размещения сплайна с данным индексом;
• ElevateOrder — Elevates the
  order of the spline to the given order;
• GetFitPoint — Читает точку размещения с заданным индексом;
• Reverse — Меняет направление сплайна на противоположное;
• SetControlPoint — Устанавливает контрольную точку с заданным индексом;
• SetFitPoint — Задает одну точку размещения сплайна;
• SetWeight — задает вес контрольной точки по индексу
• Degree — возвращает степень полинома образующего сплайн;
• Area — возвращает площадь замкнутого сплайна;
• IsPeriodic — является ли сплайн периодическим;
• IsPlanar — лежит ли сплайн в одной плоскости;
• IsRational — является ли сплайн рациональным;
• NumberOfControlPoints — возвращает число контрольных точек;
• NumberOfFitPoints — возвращает число точек размещения.

Пример изменения контрольных точек сплайна

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.

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

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

• AppendInnerLoop — добавляет внутреннюю петлю;
• AppendOuterLoop — добавляет внешнюю петлю;
• InsertLoopAt — вставляет петлю по указанному индексу.

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 для уменьшения размера файла штриховку
хранит не в виде множества подобных объектов, а как один повторяющийся по
определенным правилам. Имеются следующие свойства и методы:

• PatternAngle — задает угол образца штриховки;
• PatternDouble — задает пользовательскую двойную штриховку;
• PatternName — задает имя штриховки;
• PatternScale — задает масштаб штриховки;
• PatternSpace — задает пользовательский шаг штриховки;
• SetPattern — задает имя и тип штриховки.

Пример

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

• FontFile — задает файл связанный со шрифтом;
• BigFontFile — задает форму не ASCII-символов;
• Height — задает высоту символа;
• Width — задает сжатие или растяжение символов;
• ObliqueAngle — задает угол наклона текста;
• TextGenerationFlag — задает зеркальный, перевернутый или оба.

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

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.
Дополнительные свойства характерные только для текстов:

• Alignment — задает горизонтальное и вертикальное выравнивание;
• InsertionPoint — задает точку вставки;
• ObliqueAngle — задает угол наклона;
• Rotation — задает угол вращения в радианах;
• ScaleFactor — задает фактор масштабирования;
• TextAlignmentPoint — задает точку выравнивания;
• TextGenerationFlag — задает отоброжение вверх ногами,зеркальное и оба;
• TextString — задает текстовую строку.

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

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

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

• ArrayPolar — создает полярный массив;
• ArrayRectangular — создает прямоугольный массив;
• Copy — копирует текст;
• Erase — уничтожает текст;
• Mirror — зеркально отражает текст;
• Move — перемещает текст;
• Rotate — вращает текст.

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

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

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

Метод 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 textA1;/A0; under text} Пример использования форматирующих
символов

Sub FormatMText()

  Dim mtextObj As AcadMText

  Dim insertPoint(0 To 2) As Double

  Dim width As Double

  Dim textString As String