Программирование в AutoCAD
[+]
Опубликован: 21.02.2012 | Доступ: свободный | Студентов: 2072 / 508 | Оценка: 4.20 / 4.40 | Длительность: 19:35:00
Темы: Программирование, САПР
Специальности: Разработчик аппаратуры
Теги: autocad, autolisp, DCL, DVB, DXF, lisp, LSP, objective-c, radius, vba, viewport, VLA, библиотеки, видовые экраны, интерфейсы, переключатели, поиск, полилиния, приложения, программирование, пространство модели, процедуры, спецификации, указатели, цвета, шрифты, элементы
Лекция 8:

Программирование на VBA
A
|
версия для печати
< Лекция 7 || Лекция 8: 12345678910111213 || Лекция 9 >

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  Set plineObj = ThisDrawing.ModelSpace.AddPolyline(points)

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

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

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

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

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

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

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

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

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

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

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

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

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

  mSize = 4: nSize = 4

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

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

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

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

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

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

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

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

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

Пример:

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Дальше >>
< Лекция 7 || Лекция 8: 12345678910111213 || Лекция 9 >

Вопросы и ответы

вопросов: 2
Алексей Тимонин
Алексей Тимонин
ответить
Алексей Потапкин
Алексей Потапкин

Здравствуйте.

Подскажите, пожалуйста, каким образом можно передать параметры в макрос написанный в Autocad на VBA? Например, есть процедура, которая отрисовывает заштрихованный прямоугольник (см. ниже). Как её изменить, чтобы на входе от пользователя требовалось ввести также в качестве параметров координаты углов прямоугольника?

Public Sub DrawHatchedBox()

...

End Sub

ответить