Каким образом построить точки и/или сразу полилинию по координатам X, Y?
Здравствуйте, уважаемые форумчане.
У меня вопрос, в принципе, такой же, как и название самой темы. Но вот, к сожалению, так и не нашел на него ответ. Сформулирую его ещё раз. Каким образом построить точки и/или сразу полилинию по координатам X, Y?
Подробнее…
AutoCAD 2008. Есть таблица координат точек (их очень много). Необходимо просто их нанести на чертеж, а затем соединить полилинией. Это будут участки отвода земель под строительство. Так вот хочу у вас поинтересоваться: возможно осуществить данное действие, не прибегая к «топорному» методу – вбивая координаты одну за одной? А что-то сотворить, затратив минимум энергии. Я готов к трудностям, но когда не знаешь до конца возможностей AutoCAD и тупо прёшь в гору, когда можно (наверняка) обойти, тогда, я считаю, необходимо найти правильное решение, руководствуясь советами опытных людей. Заранее благодарен за помощь или просто совет.
Просмотров: 25124
| Homo(v)sapiens |
| Посмотреть профиль |
| Найти ещё сообщения от Homo(v)sapiens |
Регистрация: 11.05.2005
Сообщений: 6,991
Сообщение от Homo(v)sapiens
Есть таблица координат точек (их очень много).
В каком виде таблица? xls файл, txt файл, таблица Автокада, что-то еще?
__________________
Как использовать код на Лиспе читаем здесь
LISP, C# (ACAD 200[9,12,13,14])
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,810
Homo(v)sapiens, во-первых, у тебя AutoCAD, а раздел — Вертикальные решения. Во-вторых, займись поиском.
__________________
Моя библиотека lisp-функций
—
Обращение ко мне — на «ты».
Все, что сказано — личное мнение.
| Кулик Алексей aka kpblc |
| Посмотреть профиль |
| Посетить домашнюю страницу Кулик Алексей aka kpblc |
| Найти ещё сообщения от Кулик Алексей aka kpblc |
Регистрация: 24.10.2007
Сообщений: 151
Сообщение от Homo(v)sapiens
Здравствуйте, уважаемые форумчане.
У меня вопрос, в принципе, такой же, как и название самой темы. Но вот, к сожалению, так и не нашел на него ответ. Сформулирую его ещё раз. Каким образом построить точки и/или сразу полилинию по координатам X, Y?
Подробнее…
AutoCAD 2008. Есть таблица координат точек (их очень много). Необходимо просто их нанести на чертеж, а затем соединить полилинией. Это будут участки отвода земель под строительство. Так вот хочу у вас поинтересоваться: возможно осуществить данное действие, не прибегая к «топорному» методу – вбивая координаты одну за одной? А что-то сотворить, затратив минимум энергии. Я готов к трудностям, но когда не знаешь до конца возможностей AutoCAD и тупо прёшь в гору, когда можно (наверняка) обойти, тогда, я считаю, необходимо найти правильное решение, руководствуясь советами опытных людей. Заранее благодарен за помощь или просто совет.
в екселе скомпонуй данные так что бы в одной! ячейке получилось вот такое: x,y (без пробелов), распространяешь по всем строкам, копируешь в буфер всё что получилось, затем в автокаде вводишь команду _pline и при запросе координат вставляешь в командную строку всё скопированное. если из области геодезии задача то поменяй местами x и y (ну это ты наверное в курсе. )
| Igor’ Kulikov |
| Посмотреть профиль |
| Найти ещё сообщения от Igor’ Kulikov |
Регистрация: 16.12.2004
Сообщений: 5
В дополнение к преддиущему посту
Сохранить файл как csv(COMMA DELIMITED)
Открыть фаил в notepad
должно быть что-то типа
Скопировать все в буфер(Ctrl+C)
Так как массив трехмерный то В автокаде —
3dpoly
в ответ на Specify start point of polyline:
Вставить буфер в цоммандную строку (Ctrl+V)
LISP, C# (ACAD 200[9,12,13,14])
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,810
Вот блин. Тема отделена.
__________________
Моя библиотека lisp-функций
—
Обращение ко мне — на «ты».
Все, что сказано — личное мнение.
| Кулик Алексей aka kpblc |
| Посмотреть профиль |
| Посетить домашнюю страницу Кулик Алексей aka kpblc |
| Найти ещё сообщения от Кулик Алексей aka kpblc |
Регистрация: 10.02.2009
Сообщений: 164
VVA, у меня таблица Автокада.
Дальше советы идут по Excel. Я попробовал предложенную манипуляцию (спасибо Igor’ Kulikov и cadhelp), всё получилось. Нанес таким образом один участок, состоящий из 6 точек. Но есть участки из 80 и более точек. Поэтому вопрос второй: можно ли из таблицы Автокада данные перенести в Excel?
Раз уж мой вопрос выделили в отдельную тему, то просьба помочь мне. Вопрос решен наполовину. Да, и за это огромное спасибо участникам.
__________________
«Если хочешь иметь то, чего никогда не имел, делай то, чего никогда не делал»
| Homo(v)sapiens |
| Посмотреть профиль |
| Найти ещё сообщения от Homo(v)sapiens |
Регистрация: 24.10.2007
Сообщений: 151
а как таблицу автокада заполнял? откуда данные? набивали что ли вручную?
| Igor’ Kulikov |
| Посмотреть профиль |
| Найти ещё сообщения от Igor’ Kulikov |
Регистрация: 11.05.2005
Сообщений: 6,991
Сообщение от Igor’ Kulikov
можно ли из таблицы Автокада данные перенести в Excel?
Выдели таблицу, щелкни на ней правой клавишей мыши и выбери «Экспорт»
Дальше можешь делать как советовали или посмотреть еще здесь:
Import xyz coords from practically any type of file.
*** Добавлено
Тот код будет работать только с английским Автокадом
Во вложении должен с любым
| IMPORTXYZ.zip (15.3 Кб, 421 просмотров) |
__________________
Как использовать код на Лиспе читаем здесь
Регистрация: 10.02.2009
Сообщений: 164
Igor’ Kulikov, вероятнее всего данные в таблицу просто тупо вбивали. Мне уже готовая таблица поступила. То что вбивали вручную уверен на 100 %, поскольку баклажиков у нас хватает, чертящих всё либо на одном слое, либо игнорирующих привязки – так просто «на глаз» строят: попала значит попала точка, а если нет, то и не заморачиваются. Потом приходится с такими «чертежами» работать и накапливать негативную энергию.
А поэтому поводу у меня параллельный вопрос. Подскажите, как правильно поступить, имея следующую задачу (это было уже в моей практике). Наращиваю очередной ярус хвостохранилища. Необходимо закоординировать ось дамбы. Я с помощью команды ‘_id Точка (у меня русский ACAD) узнаю координаты точек оси. Затем через текстовое окно (F2) копирую координаты и вставляю в таблицу. Благо, их было не так уж и много. Но всё равно чувствовал, что делаю «мартышкин труд». Хотел ещё тогда найти альтернативное решение, которое будет единственно верным, с точки зрения рациональной траты рабочего времени и своих сил. Подскажите это решение, чтобы я в очередной раз не наступил, как здесь уже было сказано, на «возможные грабли». Оно есть?
VVA, спасибо. Несколько телодвижений и таблица координат уже в Excel’е. Красота. Скачал твои вложения. Но что дальше делать, так ничего и не понял. Я просто ещё очень далек от вопросов LISP’а и как эти коды использовать. Буду искать ответы на форуме и дальше совершенствовать свои навыки работы в AutoCAD, да и просто саморазвиваться. Благодарю за помощь .
P.S. Не хочу показаться навязчивым, но вопрос мучает сознание. Как в Excel’е осуществить следующее действие (кроме как «копировать-вставить):
| в екселе скомпонуй данные так что бы в одной! ячейке получилось вот такое: x,y (без пробелов) |
__________________
«Если хочешь иметь то, чего никогда не имел, делай то, чего никогда не делал»
| Homo(v)sapiens |
| Посмотреть профиль |
| Найти ещё сообщения от Homo(v)sapiens |
геоданные по точкам или полилинии
lisp программа. Отрисовывает в модели таблицу координат (геоданные) по указанным точкам, также экспортирует в Excel таблицу координат (геоданные) по указанной полилинии. После загрузки lisp-файла вызывается коммандой «_geo_table». На запрос «Построить ведомость по [Полилиния/Точки]:» выбираем нужную опцию. Если была выбрана опция «Точки» указываем нужные точки и жмем Enter, после этого указываем левый верхний угол отрисовки таблицы. Стандартный текст должен быть Times New Roman. Если была выбрана опция «Полилиния» указываем полилинию и получаем результат в Excel.
Комментарии
Комментарии могут оставлять только зарегистрированные участники
Авторизоваться
Комментарии 1-10 из 23
rainbov , 14 мая 2008 в 10:39
Отличная программка большое спасибо поставил все работает
, 18 мая 2008 в 00:23
А как бы координаты до 3 знаков после запятой смасиерить? 🙂
remlin , 19 мая 2008 в 12:33
Ищи строку:
(geo-add-text (rtos dist 2 2) (list (+ xx 82.5) (- yy 11)) h acAlignmentCenter 0)
и меняй в функции rtos последний аргумент 2 на 3
Herndlhofеr , 19 мая 2008 в 17:28
Asp , 23 мая 2008 в 09:18
Спасибо огромное.
Milka , 27 мая 2008 в 17:21
Это мое первое общение с Lisp, я в восторге!! Огромное спасибо, программа актуальна как никогда, камень с плеч!
Как построить полилинию по координатам в автокаде
Для указания трехмерных координат кроме координат по осям 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 — система координат объекта, OCS — система координат дисплея, 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-МЕРНЫХ ОБЪЕКТОВ
Автокад поддерживает три типа трехмерных объектов: каркасная рамка, поверхность и сплошной, каждый из типов обладает своими методами создания и редактирования. Каркасная рамка представляет собой скелетное описание трехмерного объекта и состоит только из точек, линий, кривых, описывающих грани объекта. Второй тип более сложен, т.к. описывает еще и поверхность, а третий наиболее простой способ рисования реальных объектов. При этом используется базовый набор — куб, конус, цилиндр, сфера, клин и тор. Сложные объекты можно получить путем объединения, вычитания и пересечения. Еще способ получить трехмерный объект заключается во вращении плоского вокруг оси.
СОЗДАНИЕ КАРКАСНЫХ РАМОК
Для этого достаточно разместить любой плоский объект в трехмерном пространстве одним из следующих методов: указав при создании объекта три координаты, заданием плоскости построения, перемещением объекта в другую плоскость. Метод 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 ОБЪЕКТОВ
Сплошные трехмерные объекты Автокад дают наиболее полное предстваление о реальном объекте. Для их создания используются следующие методы: 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 регулирует плавность прорисовки фигуры.
Как построить полилинию по координатам в автокаде
Пример процедуры, отрисовывающей полилинию по точкам, запрашиваемым у пользователя. При вводе точек возможен ввод опций Arc/Close/Length. Если пользователь выбрал опцию Arc, то вновь отрисовываему сегменту будет заданы кривизна (правда, я не понял принцип, по которому задается кривизна дугового сегмента, а именно, принцып задания тангенса ? угла дугового сегмента Bulge). При выборе опции Close полилиния замыкается. Кроме того, вместо ввода точки можно ввести рассояние, и, тогда точка будет расположена на введенном расстоянии от предидущей точки, в направлении, заданным отрезком, соединяющим предидущую точку с точкой полпжения курсора. Для прерываня команды можно нажать клавишу ESC. Для отслеживания нажатия клавиши ESC используется API функция GetAsyncKeyState
Поместите в стандартный модуль следующий код и запустите макрос DrawPline:
Option Explicit Public Const VK_ESCAPE = &H1B Declare Function GetAsyncKeyState Lib "user32" _ (ByVal vKey As Long) As Integer Public Sub DrawPline() Dim blnArc As Boolean Dim strPrompt As String Dim varpnt As Variant Dim dblAngl As Double Static objPLine As AcadPolyline Static dblStrPnt(0 To 2) As Double Dim dblRad(0 To 2) As Double Static varVertList(0 To 5) As Double Dim intNoPnts As Integer Dim KeyWords As String Dim strUserInput As String KeyWords = "Arc Close Line LEngth" strPrompt = "Specify Start Point: " On Error GoTo ErrControl ThisDrawing.Utility.InitializeUserInput 36, KeyWords varpnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt) strPrompt = "Specify next point or [Arc/Close/LEngth]: " Do On Error GoTo ErrControl If intNoPnts = 0 Then varVertList(0) = varpnt(0) varVertList(1) = varpnt(1) varVertList(2) = varpnt(2) intNoPnts = intNoPnts + 1 ElseIf intNoPnts = 1 Then varVertList(3) = varpnt(0) varVertList(4) = varpnt(1) varVertList(5) = varpnt(2) Set objPLine = ThisDrawing.ModelSpace.AddPolyline(varVertList) ThisDrawing.Application.Update intNoPnts = intNoPnts + 1 Else dblStrPnt(0) = varpnt(0) dblStrPnt(1) = varpnt(1) dblStrPnt(2) = varpnt(2) intNoPnts = intNoPnts + 1 objPLine.AppendVertex dblStrPnt End If If blnArc Then ' Bulge the vertex (Кривизна сегмента) dblAngl = Atn(ThisDrawing.Utility.AngleFromXAxis _ (objPLine.Coordinate(intNoPnts - 2), varpnt)) * 0.125 ' Thats not the real value, I just made it up for now. ' Честно говоря, я не понял принципа, по которому авторы ' задают кривизну дуги. Упомяну толко, что кривизна дугового ' сегмента задается параметром Bulge, равным тангенсу 1/4 угла ' дуги (Tan(dblAngl/4)). Как задавать эту величину - дело Ваше objPLine.SetBulge intNoPnts - 2, dblAngl End If ThisDrawing.Application.Update ThisDrawing.Utility.InitializeUserInput 36, KeyWords On Error Resume Next varpnt = ThisDrawing.Utility.GetPoint(varpnt, strPrompt) Select_Here: If Err Then If Err.Description = "User input is a keyword" Then strUserInput = ThisDrawing.Utility.GetInput Err.Clear If strUserInput = "Arc" Then blnArc = True strPrompt = "Specify endpoint of arc or [Line/Close]: " ThisDrawing.Utility.InitializeUserInput 36, KeyWords varpnt = ThisDrawing.Utility.GetPoint(varpnt, strPrompt) If Err Then GoTo Select_Here End If ElseIf strUserInput = "Line" Then blnArc = False strPrompt = "Specify next point or [Arc/Close/LEngth]: " ThisDrawing.Utility.InitializeUserInput 36, KeyWords varpnt = ThisDrawing.Utility.GetPoint(varpnt, strPrompt) If Err Then GoTo Select_Here End If ElseIf strUserInput = "Close" Then intNoPnts = intNoPnts + 1 objPLine.Closed = True If blnArc Then dblAngl = Atn(ThisDrawing.Utility.AngleFromXAxis _ (objPLine.Coordinate(intNoPnts - 2), varpnt)) * 0.125 objPLine.SetBulge intNoPnts - 2, dblAngl End If GoTo Exit_Here End If Else GoTo ErrControl End If End If Loop Exit_Here: Exit Sub ErrControl: ' В случе возникновения ошибки проверяем, ' не нажал ли пользователь ESC If CheckKey(VK_ESCAPE) Then Resume Exit_Here ElseIf Err.Description = "User input is a keyword" Then ' Nothing yet! Resume Exit_Here Else MsgBox Err.Description, vbOKOnly, "Llama Control Center" End If End Sub Function CheckKey(lngKey As Long) As Boolean If GetAsyncKeyState(lngKey) Then CheckKey = True Else CheckKey = False End If End Function
Отрисовка полилинии с вставкой заданного блока в ее вершинах
Пример процедуры, отрисовывающей полилинию по точкам, запрашиваемым у пользователя. При отрисовке полилинии, кроме того, что отрисовывается собственно полилиния, в ее вершины вставляются блоки с заданым именем. Для опробывания примера поместите в стандартный модуль следующий ниже код. Затем создайте в текущем чертеже чертеже блок с именем «BlkName«. Теперь запустите макрос TEST_DrawPlineWsBlock.
Option Explicit Public Sub DrawPlineWsBlock(strBlkName As String, dblScale As Double,_ dblRot As Double) Dim strPrompt As String Dim varPnt As Variant Static objPLine As AcadPolyline Static dblStrPnt(0 To 2) As Double Static varVertList(0 To 5) As Double Static intNoPnts As Integer strPrompt = "Pick The Start Point" On Error Resume Next Do varPnt = Empty varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt) If IsEmpty(varPnt) Then Exit Do If intNoPnts = 0 Then varVertList(0) = varPnt(0) varVertList(1) = varPnt(1) varVertList(2) = varPnt(2) ThisDrawing.ModelSpace.InsertBlock varPnt, strBlkName, _ dblScale, dblScale, dblScale, dblRot intNoPnts = intNoPnts + 1 ElseIf intNoPnts = 1 Then strPrompt = "Pick the next point" varVertList(3) = varPnt(0) varVertList(4) = varPnt(1) varVertList(5) = varPnt(2) Set objPLine = ThisDrawing.ModelSpace.AddPolyline(varVertList) ThisDrawing.ModelSpace.InsertBlock varPnt, strBlkName, _ dblScale, dblScale, dblScale, dblRot ThisDrawing.Application.Update intNoPnts = intNoPnts + 1 Else dblStrPnt(0) = varPnt(0) dblStrPnt(1) = varPnt(1) dblStrPnt(2) = varPnt(2) intNoPnts = intNoPnts + 1 ThisDrawing.ModelSpace.InsertBlock varPnt, strBlkName, _ dblScale, dblScale, dblScale, dblRot objPLine.AppendVertex dblStrPnt ThisDrawing.Application.Update End If Loop While Val(varPnt(0)) End Sub Public Sub TEST_DrawPlineWsBlock() Dim strBlkName As String ' Имя блока Dim dblScale As Double ' Масштаб вставки блока Dim dblRotAng As Double ' Угол поворота блока strBlkName = "BlkName" dblScale = 1 dblRotAng = 0 DrawPline strBlkName, dblScale, dblRotAng End Sub
Определение выбранного пользователем сегмента полилинии
После запуска AddSelectedPoint у пользователя запрашивается полилиния. После указания полилинии к ней добавляется вершина, координаты которой совпадают с точкой указания полилинии. К сожалению функция ThisDrawing.Utility.GetEntity используемая для запроса у пользователя полилинии, и возвращающая точку указания, работает не совсем точно. Точка указания, возвращаемая этой функцией, не находится на указанном объекте, что вызвано тем, что курсор мыши имеет квадратную форму и собственные размеры, а точка указания находится в центре этого курсора. К сожалению разработчики (в версии AutoCAD 2000) не позаботились о том, чтобы функция ThisDrawing.Utility.GetEntit при возвращени точки указания вычисляла координаты точки, лежащей на указанном объекте и ближайшей к точке курсора мыши. Может в более поздних версиях ситуация изменится?
Option Explicit Private Declare Function PtInRegion Lib "gdi32" _ (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long Private Declare Function CreateRectRgn Lib "gdi32" _ (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _ ByVal Y2 As Long) As Long Private Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long ' Добавление к выбранной полилинии вершины в ' указанной пользователем точке. Вершина добавляется в ' сегмент, ближайший к указанной точке Public Sub AddSelectedPoint() Dim varPnt As Variant Dim objPline As AcadLWPolyline Dim varStart As Variant Dim varEnd As Variant Dim lngRgn As Long Dim intVCnt As Integer Dim varCords As Variant Dim varVert As Variant Dim varCord As Variant Dim varNext As Variant Dim intCrdCnt As Integer Dim dblTemp As Double Dim intCnt As Integer Dim dblVertex(0 To 1) As Double On Error GoTo Err_Control intCnt = 1 ThisDrawing.Utility.GetEntity objPline, varPnt varCords = objPline.Coordinates For Each varVert In varCords intVCnt = intVCnt + 1 Next For intCrdCnt = 0 To intVCnt / 2 - 1 If intCrdCnt < intVCnt / 2 - 1 Then varCord = objPline.Coordinate(intCrdCnt) varNext = objPline.Coordinate(intCrdCnt + 1) lngRgn = CreateRectRgn(CLng(varCord(0)), _ CLng(varCord(1)), CLng(varNext(0)), CLng(varNext(1))) If PtInRegion(lngRgn, CLng(varPnt(0)), CLng(varPnt(1))) <> 0 Then dblVertex(0) = varPnt(0) dblVertex(1) = varPnt(1) objPline.AddVertex intCnt, dblVertex Exit For End If DeleteObject lngRgn End If intCnt = intCnt + 1 Next intCrdCnt Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub ' Second Function ' This one returns the nearest segment to the picked point: ' Функция возвращает номер сегмента, ближайшего к указанной ' точке Public Function ReturnSegment() As Integer Dim varPnt As Variant Dim objPline As AcadLWPolyline Dim varStart As Variant Dim varEnd As Variant Dim lngRgn As Long Dim intVCnt As Integer Dim varCords As Variant Dim varVert As Variant Dim varCord As Variant Dim varNext As Variant Dim intCrdCnt As Integer Dim dblTemp As Double Dim intCnt As Integer On Error GoTo Err_Control intCnt = 1 ThisDrawing.Utility.GetEntity objPline, varPnt varCords = objPline.Coordinates For Each varVert In varCords intVCnt = intVCnt + 1 Next For intCrdCnt = 0 To intVCnt / 2 - 1 If intCrdCnt < intVCnt / 2 - 1 Then varCord = objPline.Coordinate(intCrdCnt) varNext = objPline.Coordinate(intCrdCnt + 1) lngRgn = CreateRectRgn(CLng(varCord(0)), _ CLng(varCord(1)), CLng(varNext(0)), CLng(varNext(1))) If PtInRegion(lngRgn, CLng(varPnt(0)), CLng(varPnt(1))) <> 0 Then ReturnSegment = intCnt Exit For End If DeleteObject lngRgn End If intCnt = intCnt + 1 Next intCrdCnt Exit_Here: Exit Function Err_Control: MsgBox Err.Description Resume Exit_Here End Function
В данном примере при определении номера указанного пользователем сегмента используется API функции CreateRectRgn и PtInRegion. В цыкле перебираются все сегменты полилинии. Через вершины сегментов строится прямоугольный регион, а затем проверяется, находится ли точка внутри полигона. Если точка внутри полигона, то, считается, что сегмент найден. Такой способ очень не точен. взгляните на рисунок с низу. В случае а) все сработает, а вот в случае б) функция может вернуть не верный номер сегмента, здесь все зависит от того, в каком порядке сегменты добавлялись к полилинии. Какой сегмент был создан раньше, тот и будет возвращен. А в случе в) функция вообще не найдет ближайшего сегмента. Также этот метод не сработает в случае с вертикальными или горизонтальными прямолинейными сегментами.
Попробуйте сами решить эту проблему. Я решил ее находя в цикле рассояния от точки, возвращаемой функцией GetEntity до каждого сегмента полилинии по нормали. До какого сегмента расстояние меньше, тот и считается выбранным. Честно говоря, код получился не из изящных, поэтому, хоть я и не заметил ошибок в его работе, здесь я его размещать не буду.
Набор функций для получения свойств сегмента полилинии
Набор приведенных ниже функций позволит определить вид сегмента (Линия, Окружность, Дуга), и, если сегмент является дугой, то можно определить радиус дугового сегмента и координаты его центра.
' Функция, определяющая является ли сегмент перед вершиной ' Vertex полилинии PolyLin дуговым сегментом Public Function IsArc(PolyLin As AcadLWPolyline, _ Optional Vertex As Integer) As Boolean Dim Bulg As Double If Vertex = Empty Then Vertex = 0 Bulg = PolyLin.GetBulge(Vertex) If Bulg <> 0 Then IsArc = True End Function ' Функция, определяющая является ли сегмент перед вершиной ' Vertex полилинии PolyLin окружностью Public Function IsSemiCircle(PolyLin As AcadLWPolyline, _ Optional Vertex As Integer) As Boolean Dim Bulg As Double If Vertex = Empty Then Vertex = 0 Bulg = PolyLin.GetBulge(Vertex) If Bulg = 1 Or Bulg = -1 Then IsArc = True End Function ' Функция принимает значение True, если ли сегмент перед ' вершиной Vertex полилинии PolyLin описан по часовой ' стрелке Public Function ClockWise(PolyLin As AcadLWPolyline, _ Optional Vertex As Integer) As Boolean Dim Bulg As Double If Vertex = Empty Then Vertex = 0 Bulg = PolyLin.GetBulge(Vertex) If Bulg < 0 Then ClockWise = True End Function ' Функция определяющая радиус дугового сегмента полилинии Public Function Radius(PolyLin As AcadLWPolyline, _ Optional Vertex As Integer) As Double Dim PolyPts As Variant Dim PolySp(0 To 2) As Double Dim PolyEp(0 To 2) As Double Dim Lin1 As AcadLine Dim Ang As Double Dim IsoAng As Double Dim Bulg As Double If Vertex = Empty Then Vertex = 0 Bulg = PolyLin.GetBulge(Vertex) Ang = Atn(Bulg) * 4 IsoAng = Ang / 3.141592654 * 180 If IsoAng < 0 Then IsoAng = (IsoAng + 180) / 2 Else IsoAng = (180 - IsoAng) / 2 End If IsoAng = IsoAng / 180 * 3.141592654 PolyPts = PolyLin.Coordinates PolySp(0) = PolyPts(0): PolySp(1) = PolyPts(1) PolyEp(0) = PolyPts(2): PolyEp(1) = PolyPts(3) Set Lin1 = ThisDrawing.ModelSpace.AddLine(PolySp, PolyEp) Radius = (Lin1.Length / 2) / Cos(IsoAng) Lin1.Delete End Function ' Функция определяющая радиус дугового сегмента полилинии ' В отличие от предидущей функции как параметры здесь ' используютсе не Полилиния и Номер сегмента а собственно ' Начальная и Конечнная точки сегмента и параметр, харак- ' терезующий кривизну сегмента полилинии, равный ' Tg(SAng/4), где SAng - угол дугового сегмента Public Function BulgeRadius(varSPnt As Variant, _ varEPnt As Variant, dblbulge As Double) As Double Dim dblLen As Double Dim dblInclAng As Double Dim dblRad As Double Dim dblAng As Double dblLen = Sqr(((varSPnt(0) - varEPnt(0)) ^ 2) + _ ((varSPnt(1) - varEPnt(1)) ^ 2)) dblInclAng = Atn(Abs(dblbulge)) * 4 dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2) dblRad = (dblLen / 2) / (Cos(dblAng)) BulgeRadius = dblRad End Function ' Функция, возвращающая координаты точки центра дугового ' сегмента полилинии Public Function CenterPt(PolyLin As AcadLWPolyline, _ Optional Vertex As Integer) As Variant Dim PolyPts As Variant Dim PolySp(0 To 2) As Double Dim PolyEp(0 To 2) As Double Dim Lin1 As AcadLine Dim Ang As Double Dim IsoAng As Double Dim Radius As Double Dim ClockWise As Boolean Dim RadAng As Double Dim Bulg As Double If Vertex = Empty Then Vertex = 0 Bulg = PolyLin.GetBulge(Vertex) PolyPts = PolyLin.Coordinates PolySp(0) = PolyPts(0): PolySp(1) = PolyPts(1) PolyEp(0) = PolyPts(2): PolyEp(1) = PolyPts(3) Set Lin1 = ThisDrawing.ModelSpace.AddLine(PolySp, PolyEp) Ang = Atn(Bulg) * 4 IsoAng = Ang / 3.141592654 * 180 If IsoAng < 0 Then IsoAng = (IsoAng + 180) / 2 ClockWise = True Else IsoAng = (180 - IsoAng) / 2 End If IsoAng = IsoAng / 180 * 3.141592654 If ClockWise Then RadAng = Lin1.Angle + IsoAng + 3.141592654 Else RadAng = Lin1.Angle - IsoAng + 3.141592654 End If Radius = (Lin1.Length / 2) / Cos(IsoAng) CenterPt = ThisDrawing.Utility.PolarPoint(PolyEp, RadAng, Radius) Lin1.Delete End Function ' Функция определяющая центр дугового сегмента полилинии ' В отличие от предидущей функции как параметры здесь ' используютсе не Полилиния и Номер сегмента а собственно ' Начальная и Конечнная точки сегмента и параметр, харак- ' терезующий кривизну сегмента полилинии, равный ' Tg(SAng/4), где SAng - угол дугового сегмента Public Function BulgeCenterPnt(varSPnt As Variant, _ varEPnt As Variant, dblbulge As Double) As Variant Dim dblLen As Double Dim dblInclAng As Double Dim dblRad As Double Dim dblAng As Double Dim dblStart(2) As Double Dim dblEnd(2) As Double Dim varCenter As Variant Dim dblBase As Double Dim dblMid(2) As Double dblStart(0) = varSPnt(0) dblStart(1) = varSPnt(1) dblEnd(0) = varEPnt(0) dblEnd(1) = varEPnt(1) 'To keep these functions encapsulated I recreated 'The code you see in the radius function. dblLen = Sqr(((varSPnt(0) - varEPnt(0)) ^ 2) + _ ((varSPnt(1) - varEPnt(1)) ^ 2)) dblInclAng = Atn(Abs(dblbulge)) * 4 dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2) dblRad = (dblLen / 2) / (Cos(dblAng)) dblBase = ThisDrawing.Utility.AngleFromXAxis(dblStart, _ dblEnd) If dblbulge > 0 Then varCenter = ThisDrawing.Utility.PolarPoint(dblStart, _ dblBase - dblAng, dblRad) Else varCenter = ThisDrawing.Utility.PolarPoint(dblStart, _ dblBase + dblAng, dblRad) End If BulgeCenterPnt = varCenter End Function
Определение длины полилинии с помощью метода Explode
Представленная ниже функция определяет длину полилинии, не зависимо то того, из каких сегментов состоит эта полилиния (прямолинейных или дуговых), замкнута она или нет. Способ очень оригинальный. Здесь используется метод Explode, разбивающий полилинию на отрезки и дуги, эквивалентные ее сегментам. При этом все полученные таким образом примитивы оказываются в массиве объектов varExploded. Остается только пройтись по членам массива узнавая их длины и суммируя полученные значения, и, не забывая удалять их из чертежа. Все основано на том, чт окоманда Explode и метод Explode работают по разному. Команда удаляет взорваный объект, а метод не удаляет. Для опробывания функции поместите в стандартный модуль следующий код, создайте в чертеже несколько полилиний и запустите процедуру TEST_PolyLength
Option Explicit ' Функция, определяющая длину полилинии Public Function PolyLength(objPline As AcadLWPolyline) As Double Dim intCnt As Integer Dim varExploded As Variant Dim dblLen As Double On Error GoTo Error_Control varExploded = objPline.Explode ' Создаем масив примитивов, ' эквивалентных сегментам полилинии For intCnt = LBound(varExploded) To UBound(varExploded) If TypeOf varExploded(intCnt) Is AcadLine Then ' Текущий примитив - Отрезок dblLen = dblLen + varExploded(intCnt).Length ' Определяем длину varExploded(intCnt).Delete ' Удаляем отрезок ElseIf TypeOf varExploded(intCnt) Is AcadArc Then ' Текущий примитив - Дуга dblLen = dblLen + varExploded(intCnt).ArcLength ' Определяем длину varExploded(intCnt).Delete ' Удаляем дугу End If Next intCnt PolyLength = dblLen Exit_Here: Exit Function Error_Control: MsgBox Err.Description, Err.Number Resume Exit_Here End Function Public Sub TEST_PolyLength() Dim objGen As Object Dim varPnt As Variant Dim dblVal As Double On Error GoTo Err_Control ThisDrawing.Utility.GetEntity objGen, varPnt, "Select a polyline: " dblVal = PolyLength(objGen) MsgBox dblVal Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub
Определение длины полилинии расчетным путем
Не смотря на то, чт опредидущий способ мне больше по душе, тем не менее, расчетный способ тоже имеет право на существование. Итак:
Option Explicit Public Function PlineLenEX(objPLine As AcadLWPolyline) As Double Dim intVCnt As Integer Dim varCords As Variant Dim varVert As Variant Dim varCord As Variant Dim varNext As Variant Dim intCrdCnt As Integer Dim dblTemp As Double Dim dblArc As Double Dim dblAng As Double Dim dblChord As Double Dim dblInclAng As Double Dim dblRad As Double varCords = objPLine.Coordinates For Each varVert In varCords intVCnt = intVCnt + 1 Next 'For intCrdCnt = 0 To intVCnt / 3 - 1 ' Для AcadPolyline ' If intCrdCnt For intCrdCnt = 0 To intVCnt / 2 - 1 ' Для AcadLWPolyline If intCrdCnt Then ' Для AcadLWPolyline If objPLine.GetBulge(intCrdCnt) = 0 Then varCord = objPLine.Coordinate(intCrdCnt) 'If intCrdCnt < intVCnt / 3 - 1 Then ' Для AcadPolylineIf intCrdCnt < intVCnt / 2 - 1 Then ' Для AcadLWPolyline varNext = objPLine.Coordinate(intCrdCnt + 1) Else If objPLine.Closed Then varNext = objPLine.Coordinate(0) Else Exit For End If End If 'computes a simple Pythagorean length ' Для AcadPolyline 'dblTemp = dblTemp + Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _ '((varCord(1) - varNext(1)) ^ 2)) ^ 2) + ((varCord(2) - varNext(2)) ^ 2)) ' Для AcadLWPolyline dblTemp = dblTemp + Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _ ((varCord(1) - varNext(1)) ^ 2)) ^ 2)) Else 'If there is a bulge we need to get an arc length varCord = objPLine.Coordinate(intCrdCnt) varNext = objPLine.Coordinate(intCrdCnt + 1) ' Для AcadPolyline 'dblChord = Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _ '((varCord(1) - varNext(1)) ^ 2)) ^ 2) + ((varCord(2) - varNext(2)) ^ 2)) ' Для AcadLWPolyline dblChord = Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _ ((varCord(1) - varNext(1)) ^ 2)) ^ 2)) 'Bulge is the tangent of 1/4 of the included angle between 'vertices. So we reverse the process to get the included angle dblInclAng = Atn(Abs(objPLine.GetBulge(intCrdCnt))) * 4 dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2) dblRad = (dblChord / 2) / (Cos(dblAng)) dblArc = dblInclAng * dblRad dblTemp = dblTemp + dblArc End If End If Next PlineLenEX = dblTemp End Function Public Sub TEST_PlineLenEX() Dim objPLine As AcadLWPolyline Dim varPnt As Variant Dim dblPlLenght As Double On Error GoTo Err_Handler ThisDrawing.Utility.GetEntity objPLine, varPnt, "Выберите полилинию" dblPlLenght = PlineLenEX(objPLine) MsgBox "Длина выбранной полилинии " & CStr(dblPlLenght), _ vbInformation + vbOKOnly, "TEST_PlineLenEX" Exit Sub Err_Handler: MsgBox Err.Description Err.Clear End Sub
Реверс точек полилинии (изменеие направления)
Имеется в виду, что первая точка полилинии становится последней, вторая предпоследней и т.д. Если линия замкнутая, то она разравается. Для опробывания функции поместите в стандартный модуль следующий код, создайте в чертеже несколько полилиний и запустите процедуру TEST_ReverseLWPLine
Option Explicit ' Функция, определяющая длину полилинии Public Function ReverseLWPLine(objPline As AcadLWPolyline) _ As AcadLWPolyline Dim objRet As AcadLWPolyline Dim intVCnt As Integer Dim varCords As Variant Dim intDiv As Integer Dim dblPnts() As Double Dim objSpace As AcadBlock Dim intCnt As Integer Dim intSegCnt As Integer On Error GoTo Err_Control 'Using this method allows you to reverse PLines in blocks! Set objSpace = ThisDrawing.ObjectIdToObject(objPline.OwnerID) intDiv = 2 varCords = objPline.Coordinates ReDim dblPnts(UBound(varCords)) intSegCnt = ((UBound(varCords) - 1) / 2) - 1 For intVCnt = UBound(varCords) To LBound(varCords) Step -intDiv dblPnts(intCnt + 1) = varCords(intVCnt) dblPnts(intCnt) = varCords(intVCnt - 1) intCnt = intCnt + intDiv Next Set objRet = objSpace.AddLightWeightPolyline(dblPnts) For intCnt = 0 To intSegCnt 'Get the Bulge from the original and reverse it objRet.SetBulge intCnt, -objPline.GetBulge(intSegCnt - intCnt) Next intCnt objPline.Delete Set ReverseLWPLine = objRet Exit_Here: Exit Function Err_Control: Select Case Err.Number Case Else MsgBox Err.Description Err.Clear Resume Exit_Here End Select End Function Public Sub TEST_ReverseLWPLine() Dim objGen As Object Dim objPline As AcadLWPolyline Dim varPnt As Variant On Error GoTo Err_Control ThisDrawing.Utility.GetEntity objGen, varPnt, "Select a polyline: " Set objPline = objGen Set objPline = ReverseLWPLine(objPline) Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub
Связь площади полилинии с текстовым объектом
Очень интересный пример. Наводит, так сказать, на размышления. Поместите в модуль «ThisDrawing» текущего чертежа следующий ниже код, создайте в чертеже полилинию и текстовый объект (не Мультитекст, а однострочный текст). Запустите макрос Bind и на заданные запросы выберите сначала полилинию, а затем текст. В результате текстовый объект будет отображать площадь полилинии. Но самое интересное в переди. Измените полилинию. Просто ухватитесь за одну из ее вершин мышью и перенесите ее. Если все зделано правильно, то содержимое текстового объекта автоматически обновиться. Вот тут-то и появляются размышления. А что если вместо обычных переменных использовать массивы? Тогда можно будет связывать между собой несколько объетов чертежа. А что если при редактировании одного объекта обновлять не содержимое текстового объекта, а, например, длину другого объекта, задавая его длину расчитанной по формуле величиной, зависящей от длины редактируемого объекта? А что если при закрытии файла соответствующим образом скидывать в базу данных (в текстовый или ini файл, в реестр, наконец) метки связанных между собой примитивов, а при открытии считывать сохраненные метки, обновляя необходимые связи? Как Вам поле для деятельности? Кто сказал что в AutoCAD нет параметризации? Зделаем ее сами!
Option Explicit Dim blnEdit As Boolean Dim WithEvents objPl As AcadLWPolyline Dim objText As AcadText Public Sub Bind() Dim varPnt As Variant Dim objEnt As AcadEntity Dim strPrmt As String On Error GoTo Err_Control strPrmt = vbCr & "Выберите полилинию: " Me.Utility.GetEntity objEnt, varPnt, strPrmt Set objPl = objEnt strPrmt = vbCr & "Выберите текстовый объект: " Me.Utility.GetEntity objEnt, varPnt, strPrmt Set objText = objEnt objText.TextString = objPl.Area Exit_Here: Exit Sub Err_Control: If Err.Description = "Type mismatch" Then Resume Else MsgBox Err.Description Resume Exit_Here End If End Sub Private Sub objPl_Modified(ByVal pObject As AutoCAD.IAcadObject) blnEdit = True End Sub Private Sub AcadDocument_EndCommand(ByVal CommandName As String) On Error GoTo Error_Handler If blnEdit Then objText.TextString = objPl.Area blnEdit = Not blnEdit End If Error_Handler: End Sub
Сохранение координат полилинии в текстовом файле
Очень часто геодезисты спрашивают: «А нельзя ли сохранить координаты вершин указанной полилинии в текстовом или каком другом файле?» Мне даже попадались примеры на AutoLISP, выполняющие эту задачу. Представляю Вашему вниманю вариант решения этой задачи с помощью VBA. Поместите в стандартный модуль следующий код, создайте полилинию и запустите макрос ExportVerts.
Option Explicit Public Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long Public Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ ' Display and use the File open dialog '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Public Function ShowOpen() As String Dim strTemp As String Dim VertName As OPENFILENAME VertName.lStructSize = Len(VertName) VertName.hwndOwner = ThisDrawing.HWND VertName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + _ "*.txt" + Chr$(0) VertName.lpstrFile = Space$(254) VertName.nMaxFile = 255 VertName.lpstrFileTitle = Space$(254) VertName.nMaxFileTitle = 255 VertName.lpstrInitialDir = CurDir VertName.lpstrTitle = "Llamas Are Supreme" VertName.flags = 0 If GetOpenFileName(VertName) Then strTemp = (Trim(VertName.lpstrFile)) ShowOpen = Mid(strTemp, 1, Len(strTemp) - 1) End If End Function '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ ' The main procedure, if using normal PLines (Z val) ' Read the comments to get the Z coordinate '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Public Sub ExportVerts() Dim intVCnt As Integer Dim intFile As Integer Dim strFileName As String Dim strVert As String Dim retCoord As Variant Dim plineObj As AcadLWPolyline Dim intCnt As Integer Dim varVert As Variant Dim varPnt As Variant Dim varCord As Variant Dim intCrdCnt As Integer ThisDrawing.Utility.GetEntity plineObj, varPnt, _ "select the polyline to get vertices from" retCoord = plineObj.Coordinates intCnt = 1 intFile = FreeFile 'This assumes you are opening an existing file! strFileName = ShowOpen If Not Right(strFileName, 4) = ".txt" Then strFileName = strFileName & ".txt" End If Open strFileName For Append As intFile Print #intFile, " " Print #intFile, " Вершины полилинии:" For Each varVert In retCoord intVCnt = intVCnt + 1 Next For intCrdCnt = 0 To intVCnt / 2 - 1 'For normal poly 3 - 1 varCord = plineObj.Coordinate(intCrdCnt) strVert = "Вершина " & CStr(intCrdCnt + 1) & " - X=" & _ CStr(vbdRoundToDecimal(varCord(0), 2)) strVert = strVert & Space(25 - Len(strVert)) & _ "Y #008000"> '@~~~~~~~~~~~~~~~~ POWER CHANGE ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ ' If using normal Polylines, uncomment the next line 'strVert = strVert & Space(40 - Len(strVert)) & _ ' "Z #000080">Print #intFile, strVert Next Close intFile End Sub '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ ' Round it to any place you need, Jon. '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Private Function vbdRoundToDecimal(dblNumber As Variant, _ intPlace As Integer) As Double Dim dblDecimal As Double dblDecimal = 10 ^ intPlace vbdRoundToDecimal = Int(dblNumber * dblDecimal + 0.05) / dblDecimal End Function
Импорт точек полилинии виз AutoCAD в Excel и экспорт точек из Excel в AutoCAD
Вот еще один пример импорта координат вершин полилинии. На этот раз координаты импортируются из AutoCAD в таблицу Excel.
Создайте новую книгу в MS Excel, перейдите в редактор VBA и выберите пункт меню Tools -> References. В появившемся окне поставьте галочку у пункта AutoCAD 2000 Type Library. Если Вы не находите этого пункта, то нажмите кнопку Browse… и найдите файл acad.tlb. Обычно он находится в корневой папке AutoCAD. Только что мы добавили в проект ссылку на библиотеку AutoCAD, что обеспечит нам доступ ко всем функциям и объектам AutoCAD.Теперь добавьте в стандартный модуль Excel следующий ниже код. Запустите AutoCAD и создайте полилинию. Перейдите к Excel и запустите макрос ImportPoints. При этом AutoCAD активизируется и у Вас запрашивается полилиния. Выберите ее. В текущей таблице в первых двух столбцах появились координаты выбранной Вами полилинии. Теперь сделаем обратную операцию. Вернитесь к AutoCAD и удалите ту полилинию, импорт точек которой Вы только что выполнили. Вернитесь к Excel, выделите те ячейки, в которых содержаться полученные только что координаты и запустите макрос ExportPoints. Перейдите к AutoCAD и Вы увидите, что удаленная полилиния опять на месте.
'***********************ВНИМАНИЕ*************************' ' Следующий ниже код нужно добавить в стандартный модуль ' ' MS Excel. ' '********************************************************* '//////////////////NOTE///////////////////////////////// ' You will need to add a reference to the AutoCAD 2000 ' Type Library to run this example book. Use the "Tools - ' References" menu. If you prefere you can switch to late ' binding by changeing the AutoCAD types to generic objects '//////////////////ПРИМЕЧАНИЕ/////////////////////////////// ' Перед использованием представленных в этом блоке процедур ' Вы должны создать в проекте ссылку на библиотеку AutoCAD 2000 ' Type Library (файл acad.tlb, обычно он находится в корневой ' папке AutoCAD). Для этого выберите пункт меню "Tools - ' References в редакторе VBA от MS Excel Option Explicit Public Sub ImportPoints() Dim objApp As AcadApplication Dim objDoc As AcadDocument Dim objEnt As AcadEntity Dim varPnt As Variant Dim strPrmpt As String Dim intVCnt As Integer Dim varCords As Variant Dim varVert As Variant Dim varCord As Variant Dim varNext As Variant Dim intCrdCnt As Integer On Error GoTo Err_Control Set objApp = GetObject(, "AutoCAD.Application") Set objDoc = objApp.ActiveDocument AppActivate objApp.Caption objDoc.Utility.GetEntity objEnt, varPnt If TypeOf objEnt Is AcadLWPolyline Then AppActivate Application.Caption varCords = objEnt.Coordinates For Each varVert In varCords intVCnt = intVCnt + 1 Next For intCrdCnt = 0 To intVCnt / 2 - 1 varCord = objEnt.Coordinate(intCrdCnt) Application.Cells(intCrdCnt + 1, 1).Value = varCord(0) Application.Cells(intCrdCnt + 1, 2).Value = varCord(1) Next intCrdCnt Else MsgBox "Selected entity was not a LWPolyline" End If Exit_Here: If Not objApp Is Nothing Then Set objApp = Nothing Set objDoc = Nothing End If Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub Public Sub ExportPoints() Dim vertlist() As Double Dim objApp As AcadApplication Dim objDoc As AcadDocument Dim RowCount As Integer Dim strPrmpt As String Dim intCnt As Integer Dim objCell As Object Dim objSheet As Worksheet On Error GoTo Err_Control Set objSheet = ThisWorkbook.Sheets(1) Set objApp = GetObject(, "AutoCAD.Application") Set objDoc = objApp.ActiveDocument RowCount = objSheet.UsedRange.Rows.Count ReDim vertlist((RowCount * 2) - 1) RowCount = 1 For intCnt = LBound(vertlist) To UBound(vertlist) Step 2 vertlist(intCnt) = objSheet.Cells(RowCount, 1).Value vertlist(intCnt + 1) = objSheet.Cells(RowCount, 2).Value RowCount = RowCount + 1 Next objDoc.ModelSpace.AddLightWeightPolyline vertlist objDoc.Regen acActiveViewport Exit_Here: If Not objApp Is Nothing Then Set objApp = Nothing Set objDoc = Nothing End If Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub
Выделение объектов, находящихся на заданном расстоянии от полилинии
Пример выбора объектов, находящихся на заданном расстоянии от выбранной полилинии. Авторы представленого примера слегка лукавят. На самом деле происходит следующее: Пользователь выбирает полилинии и задает дисстанцию. Процедура выясняет габариты полилинии и выбирает все объекты заданного типа на заданном слое, попадающие в прямоугольное окно, стороны которого больше чем габариты полилинии на заданную пользователем величину. К стати, вместо acSelectionSetWindow (при котором выбираются только те объекты, которые полностью попадают в окно) можно подставить acSelectionSetCrossing (тогда будут выбраны и те объекты, которые не попадают в рамку полностью, но пересекаются ею.). Дла того. чтобы посмотреть как работает этот пример создайте в чертеже полилинию, создайте слой с именем Layer1, создайте несколько текстовых объектов рядом и в отдалении от полилинии и на разных слоях. Поместите код в стандартный модуль и запустите процедуру TEST_SelectTextInDist.
Option Explicit Public Function SelectTextInDist(strLayerName As String) _ As AcadSelectionSet Dim objBound As Variant Dim varMin As Variant Dim varMax As Variant Dim varPnt As Variant Dim dblDist As Double Dim strPrompt As String Dim dblFilPntMin(0 To 2) As Double Dim dblFilPntMax(0 To 2) As Double Dim intType(0 To 3) As Integer Dim varData(0 To 3) As Variant Dim objEnt As AcadEntity Dim objSelSet As AcadSelectionSet Dim objSelCol As AcadSelectionSets On Error GoTo Err_Control ' Создаем пустой набор объектов Set objSelCol = ThisDrawing.SelectionSets For Each objSelSet In objSelCol ' Проверяем все существующие наборы If objSelSet.Name = "textindistance" Then ' Если имя любого из существующих набора "trxtindistance" ThisDrawing.SelectionSets.Item("textindistance").Delete ' Удаляем этот набор во избежании ошибки, т.к. 2 набора ' с одинаковыми именами не могут сосуществовать Exit For End If Next Set objSelSet = ThisDrawing.SelectionSets.Add("textindistance") ' Присваеваем вновь созданному набору имя "trxtindistance" strPrompt = vbCrLf & "Select entity: " ' Запрашиваем объект ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrompt ' Запрашиваем расстояние strPrompt = vbCrLf & "Distance around entity to search: " dblDist = ThisDrawing.Utility.GetDistance(Prompt:=strPrompt) ' Определяем габариты выбранного объекта objEnt.GetBoundingBox varMin, varMax ' Расчитываем навые координаты для окна выбора dblFilPntMin(0) = varMin(0) - dblDist dblFilPntMin(1) = varMin(1) - dblDist dblFilPntMax(0) = varMax(0) + dblDist dblFilPntMax(1) = varMax(1) + dblDist ' Обеспечиваем фильтр выбора объектов intType(0) = -4 intType(1) = 0 intType(2) = 8 intType(3) = -4 varData(0) = "" ' Выбираем объекты рамкой с расчитанными габаритами objSelSet.Select acSelectionSetWindow, dblFilPntMin, _ dblFilPntMax, intType, varData Set SelectTextInDist = objSelSet Exit_Here: Exit Function Err_Control: MsgBox Err.Description Resume Exit_Here End Function Public Sub TEST_SelectTextInDist() Dim objEnt As AcadText Dim TestSet As AcadSelectionSet Set TestSet = SelectTextInDist("Layer1") For Each objEnt In TestSet ' Просматриваем все выбранные объекты objEnt.Highlight True ' и подсвечиваем их Next objEnt End Sub