СОЗДАНИЕ И РЕДАКТИРОВАНИЕ ПРИМИТИВОВ AUTOCAD

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

НАЗНАЧЕНИЕ ИМЕНИ И ТИПА ШТРИХОВКЕ

В автокад есть сплошная заливка и более 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 символов (буквы, цифры, спецсимволы кроме тех которые используются самим автокадом < > / \ " : ; ? * | = ' и запятая). Пример переименования

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

ВЫБОР ОБЪЕКТОВ

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

DXF-код	Тип фильтра
0	Тип объекта. Строка ("Line", "Circle", "Arc" и т.д.)
2	Имя объекта. Строка (табличное имя объекта)
8	Имя слоя. Строка ("Layer 0")
60	Видимость объекта 0-виден, 1-нет
62	Цвет. Числовой 0-256, где 0-по блоку, 256-по слою
67	Пространство. Число. модели (0) или листа (1)

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

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

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. Автокад определяет расстояние от центральной точки массива до референс-точки исходного объекта. Референс-точка зависит от типа объекта. (Для окружности и дуги это центр, для блока - точка вставки, для текста - начальная точка и т.д) Данный метод не поддерживает вращение в процессе копирования в отличие от команды 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 позволяет создать двумерный или трехмерный прямоугольный массив. Он требует число строк, столбцов, расстояния между ними, при создании трехмерного массива требуется так же указать количество уровней и расстояния между ними. Если задать одну строку, то следует указать несколько столбцов и наоборот. Предполагается что оригинальный объект расположен в левом нижнем углу массива, а сам массив создается вверх и вправо. Если нужно вниз и влево, задавай отрицательные расстояния между строками и столбцами.

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

ТРАНСФОРМИРОВНИЕ ОБЪЕКТОВ

Конфигурация матрицы трансформации
R00	R01	R02	T0
R10	R11	R12	T1
R20	R21	R22	T2
0	0	0	1

Перед трансформацией объекта следует заполнить матрицу трансформации. В следующем примере объект вращается на 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

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

1. Вращение на 45 градусов вокруг точки (5,5,0)
0.707107	-0.707107	0.0	5.0
0.707107	0.707107	0.0	-2.071068
0.0	0.0	1.0	0.0
0.0	0.0	0.0	1.0

2. Перемещение в точку (10,10,0)
1.0	0.0	0.0	10.0
0.0	1.0	0.0	10.0
0.0	0.0	1.0	0.0
0.0	0.0	0.0	1.0

3. Масштабирование в 10,10 на точке (0,0,0)
10.0	0.0	0.0	0.0
0.0	10.0	0.0	0.0
0.0	0.0	10.0	0.0
0.0	0.0	0.0	1.0

4. Масштабирование в 10,10 на точке (2,2,0)
10.0	0.0	0.0	-18.0
0.0	10.0	0.0	-18.0
0.0	0.0	10.0	0.0
0.0	0.0	0.0	1.0

УДЛИНЕНИЕ И ПОДРЕЗКА ОБЪЕКТОВ

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

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

• 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

РЕДАКТИРОВАНИЕ ОБРАЗЦА ШТРИХОВКИ

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

• 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

Читать дальше - В начало - На главную