Нумерация вершин полилинии по выбранному блоку и создание таблицы с номерами вершин и координатами

ati96 · 17.10.2023, 13:34

Коллеги, добрый день!
Не нашел похожей темы и поэтому создал новую
Проблема в следующем: часто приходится оформлять сервитуты на ЗУ и приходится нумеровать вершины полилинии, затем по проставленным блокам по вершинам извлекать координаты в эксель файл и потом уже снова вставлять в чертеж.
В лисп не силен и все собрано буквально на коленке
Нужно чтобы лисп делал следующее:
1. выбираешь полилинию
2. Выбираешь блок (блок с атрибутом, чтобы менять номер вершины), как исходник для проставления вершин. Первая вершина должна быть под номером один, а каждая следующая соответственно на один больше.
3. Лисп проставил вершины и создал таблицу, где проставлены номера вершин и координаты Х и Y.

Примерно так. Может уже есть что-то подобное и просто направите меня.
Лисп и пример блока ниже.

Код:

[Выделить все]

 (defun c:servitut4 ()
  (vl-load-com)
  
  ;; Просим выбрать полилинию
  (setq polyline-selection (ssget '((0 . "LWPOLYLINE"))))
  
  (if polyline-selection
      (progn
        ;; Выбираем полилинию из выборки
        (setq polyline (vlax-ename->vla-object (ssname polyline-selection 0)))
        
        ;; Просим выбрать блок
        (setq pt (getpoint "\nУкажите блок на модели: "))
        (setq block-name (cdr (assoc -1 (entget (car (entsel pt))))))
        
        ;; Просим указать имя таблицы
        (setq table-name (getstring t "\nEnter table name: "))
        
        ;; Создаем таблицу
        (setq table (vla-add (vla-get-database polyline) (vla-get-activelayout (vla-get-documents polyline)) "Table" (vla-get-activexobject "ACAD.Table")))
        
        (defun get-polyline-vertices (polyline)
          (setq vertices '())
          (vlax-for vertex (vlax-in polyline 'vertices)
            (setq vertices (cons (vlax-get-property vertex 'coordinates) vertices)))
          (reverse vertices))
        
        (defun insert-block-at-vertex (vertex block-name)
          (setq insertion-point (cdr (assoc 10 vertex)))
          (setq angle (cdr (assoc 40 vertex)))
          (command "-insert" block-name insertion-point angle))
        
        (defun add-to-table (table vertices)
          (setq count 1)
          
          (vlax-for row (vlax-get-property table 'rows)
            (vla-delete row))
          
          (foreach vertex vertices
            (setq point (cdr (assoc 10 vertex)))
            
            ;; Добавляем новую строку в таблицу
            (setq newRow (vla-addrow table))
            
            ;; Задаем значение номера вершины в ячейку A
            (vla-settextstring (vla-get-cell newRow 0) (strcat "Vertex " (itoa count)))
            
            ;; Задаем значение координаты вершины в ячейку B
            (setq coordinates (apply 'strcat (mapcar '(lambda (coord) (rtos coord 2 6)) point)))
            (vla-settextstring (vla-get-cell newRow 1) coordinates)
            
            (setq count (+ count 1))))
        
        (setq vertices (get-polyline-vertices polyline))
        
        (foreach vertex vertices
          (insert-block-at-vertex vertex block-name))
        
        (add-to-table table vertices)
        
        (princ "Блок успешно размещен на вершинах полилинии и данные добавлены в таблицу.")
      )
      (princ "Не найдено ни одной полилинии.")
    )
  (princ)
)

Maksim7enov · 18.10.2023, 14:10

Добрый день! Отлов ошибок не делал. Если правильно понял, то получается следующий код. Думаю доработаете как Вам надо.

Код:

[Выделить все]

 
(defun c:inserttablecoord (/ adoc ss1 ss2 cord n blk lstcordname i objtabl1)
  (setq adoc (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) ;_ end of vla-get-modelspace
  ) ;_ end ofsetq
  (while (not (setq ss1 (car (entsel "\nВыберите полилинию: ")))) (princ "\nMiss!"))
  (while (not (setq ss2 (car (entsel "\nВыберите блок: ")))) (princ "\nMiss!"))
  (setq nametable (getstring "\nВведите имя таблицы: "))
  (setq cord (mapcar 'cdr (vl-remove-if '(lambda (x) (/= 10 (car x))) (entget ss1))) ;_ end of  mapcar
  ) ;_ end of setq
  (setq n 1)
  (foreach q cord
    (setq blk (vla-insertblock adoc
                               (vlax-3d-point q)
                               (vla-get-effectivename (vlax-ename->vla-object ss2))
                               1
                               1
                               1
                               0
              ) ;_ end ofvla-InsertBlock
    ) ;_ end ofsetq
    (vla-put-textstring (car (_att_in_blk blk "НОМЕР_ВЕРШИНЫ")) (vl-princ-to-string n))
    (setq lstcordname (cons (cons n q) lstcordname))
    (setq n (1+ n))
  ) ;_ end offoreach
   (setq lstcordname (REVERSE lstcordname))
  (setq i 0)
  (setq objtabl1 (vla-addtable adoc
                               (vlax-3d-point (getpoint "\nУкажите точку вставки таблицы: ")) ;_ end of vlax-3d-point
                               (+ (length cord) 2)
                               3
                               8
                               30
                 ) ;_ end of vla-AddTable
  ) ;_ end of setq
  (vla-settext objtabl1 0 0 nametable)
  (vla-settext objtabl1 (+ i 1) 0 "Точка")
  (vla-settext objtabl1 (+ i 1) 1 "X")
  (vla-settext objtabl1 (+ i 1) 2 "Y")
  (while (< i (length cord))
    (vla-settext objtabl1 (+ i 2) 0 (vl-princ-to-string (car (nth i lstcordname))));название точки
    (vla-settext objtabl1 (+ i 2) 1 (vl-princ-to-string (cadr (nth i lstcordname))));координата X
    (vla-settext objtabl1 (+ i 2) 2 (vl-princ-to-string (caddr (nth i lstcordname))));координата Y
    (setq i (1+ i))
  ) ;_ end of while
  (vla-setalignment objtabl1 1 acmiddlecenter)
  (vla-settextheight objtabl1 acdatarow 2.5)
  (vla-settextheight objtabl1 actitlerow 5)
) ;_ end ofdefun

(defun _att_in_blk (obj lsttag /)                 
  (cond ((not lsttag) (setq lsttag (list "*")))
        ((atom lsttag) (setq lsttag (list lsttag)))
  ) ;_ end of cond
  (vl-member-if '(lambda (x)
                   (apply 'wcmatch
                          (list (strcase (vla-get-tagstring x))
                                (apply 'strcat (mapcar '(lambda (str) (strcase (strcat str ","))) lsttag)) ;_ end of apply
                          ) ;_ end of cons
                   ) ;_ end of apply
                 ) ;_ end of lambda
                (vl-catch-all-apply
                  '(lambda ()
                     (append (vlax-invoke obj 'getattributes) (vlax-invoke obj 'getconstantattributes)) ;_ end of append
                   ) ;_ end of lambda
                ) ;_ end of vl-catch-all-apply
  ) ;_ end of vl-member-if
) ;_ end of defun

trir · 18.10.2023, 14:50

Map 3D, FDO, SQL

ati96 · 20.10.2023, 10:59

Maksim7enov, большое спасибо за помощь.
Попробовал ваш лисп.
По нему происходит следующее: выбор полилинии, выбор блока, а затем ввод названия таблицы. После всех выборов создается таблица, с одной строкой, где прописана цифра один и координаты Х,У, равные нулю. Блок по вершинам не проставляется.
Пытался добить, но что-то не выходит((

Maksim7enov · 20.10.2023, 11:25

У меня все работает) Выбираете блок который в файле прикрепленном в теме? Пришлите файл с ошибкой

ati96 · 20.10.2023, 12:26

Maksim7enov, да, выбираю тот же самый блок, который скидывал. Ошибки как таковой нет, но блоки не проставляются по вершинам полилинии, а про таблицу уже писал)
Прикрепил скрин результата

Maksim7enov · 20.10.2023, 12:46

Без файла в котором ошибка ничего сказать не могу! В лиспе что еще менялось кроме названия? В файле который прикреплен тоже ошибка?

ati96 · 20.10.2023, 14:04

Maksim7enov, кроме названия больше ничего не менял.
Файл прилагаю
Ошибок вроде никаких нет

Maksim7enov · 20.10.2023, 14:18

Проблема в объекте "2d-полилиния". Если начертить объектом "LWPOLYLINE" то все будет работать! У "2d-полилиния" dfx код 10 выдает только ((0.0 0.0 0.0)), вот и получается всего 1 координата

Maksim7enov · 20.10.2023, 15:20

Тогда сделаем так. Немного кустарно, но работать будет и с 2d-полилинией. Тестируйте

Код:

[Выделить все]

 (defun c:inserttablecoord (/ adoc ss1 ss2 cord n blk lstcordname i objtabl1 nametable)
  (setq adoc (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) ;_ end of vla-get-modelspace
  ) ;_ end ofsetq
  (while (not (setq ss1 (car (entsel "\nВыберите полилинию: ")))) (princ "\nMiss!"))
  (while (not (setq ss2 (car (entsel "\nВыберите блок: ")))) (princ "\nMiss!"))
  (setq nametable (getstring "\nВведите имя таблицы: "))
  (setq cord (fun-coordpolily (vlax-ename->vla-object ss1)))
  (setq n 1)
  (foreach q cord
    (setq blk (vla-insertblock adoc
                               (vlax-3d-point q)
                               (vla-get-effectivename (vlax-ename->vla-object ss2))
                               1
                               1
                               1
                               0
              ) ;_ end ofvla-InsertBlock
    ) ;_ end ofsetq
    (vla-put-textstring (car (_att_in_blk blk "НОМЕР_ВЕРШИНЫ")) (vl-princ-to-string n))
    (setq lstcordname (cons (cons n q) lstcordname))
    (setq n (1+ n))
  ) ;_ end offoreach
  (setq lstcordname (reverse lstcordname))
  (setq i 0)
  (setq objtabl1 (vla-addtable adoc
                               (vlax-3d-point (getpoint "\nУкажите точку вставки таблицы: ")) ;_ end of vlax-3d-point
                               (+ (length cord) 2)
                               3
                               8
                               30
                 ) ;_ end of vla-AddTable
  ) ;_ end of setq
  (vla-settext objtabl1 0 0 nametable)
  (vla-settext objtabl1 (+ i 1) 0 "Точка")
  (vla-settext objtabl1 (+ i 1) 1 "X")
  (vla-settext objtabl1 (+ i 1) 2 "Y")
  (while (< i (length cord))
    (vla-settext objtabl1 (+ i 2) 0 (vl-princ-to-string (car (nth i lstcordname)))) ;название точки
    (vla-settext objtabl1 (+ i 2) 1 (rtos (cadr (nth i lstcordname)) 2)) ;координата X
    (vla-settext objtabl1 (+ i 2) 2 (rtos (caddr (nth i lstcordname))2)) ;координата Y
    (setq i (1+ i))
  ) ;_ end of while
  (vla-setalignment objtabl1 1 acmiddlecenter)
  (vla-settextheight objtabl1 acdatarow 2.5)
  (vla-settextheight objtabl1 actitlerow 5)
) ;_ end ofdefun

(defun _att_in_blk (obj lsttag /)
  (cond ((not lsttag) (setq lsttag (list "*")))
        ((atom lsttag) (setq lsttag (list lsttag)))
  ) ;_ end of cond
  (vl-member-if '(lambda (x)
                   (apply 'wcmatch
                          (list (strcase (vla-get-tagstring x))
                                (apply 'strcat (mapcar '(lambda (str) (strcase (strcat str ","))) lsttag)) ;_ end of apply
                          ) ;_ end of cons
                   ) ;_ end of apply
                 ) ;_ end of lambda
                (vl-catch-all-apply
                  '(lambda ()
                     (append (vlax-invoke obj 'getattributes) (vlax-invoke obj 'getconstantattributes)) ;_ end of append
                   ) ;_ end of lambda
                ) ;_ end of vl-catch-all-apply
  ) ;_ end of vl-member-if
) ;_ end of defun


(defun fun-coordpolily (sels / cord n cordinate)
  (setq cord1 (vlax-safearray->list (vlax-variant-value (vla-get-coordinates sels))))
  (setq n 0)
  (cond ((= (vla-get-objectname sels) "AcDbPolyline")
         (setq vert (/ (length cord1) 2))
        )
        ((= (vla-get-objectname sels) "AcDb2dPolyline")
         (setq vert (/ (length cord1) 3))
        )
        (t nil)
  ) ;_ end ofcond
  (repeat vert
    (setq cordinate (cons (vlax-safearray->list (vlax-variant-value (vla-get-coordinate sels n))) cordinate))
    (setq n (1+ n))
  ) ;_ end ofrepeat
  (reverse cordinate)
) ;_ end ofdefun

ati96 · 21.10.2023, 15:48

Maksim7enov, огромное спасибо, все работает!
Подскажите а в рамках лиспа возможно сделать так, чтобы еще был запрос на то, с какой цифры начинать атрибут блока? Не подскажите как ее можно добавить в код, если такое возможно?

Maksim7enov · 23.10.2023, 13:42

Цитата:

Сообщение от ati96

Maksim7enov, огромное спасибо, все работает!
Подскажите а в рамках лиспа возможно сделать так, чтобы еще был запрос на то, с какой цифры начинать атрибут блока? Не подскажите как ее можно добавить в код, если такое возможно?

необходимо заменить строку 8 на

Код:

[Выделить все]

 (setq n (getint "\\nВведите стартовый номер вершины:"))

dro.n · 24.11.2023, 10:15

Maksim7enov, здравствуйте! Очень нужный лисп, но есть проблема, которую не получается решить. Что нужно прописать в лиспе, чтобы значения x, y из Автокад прописывались в колонках x, y наоборот? В соответствии с географическими координатами на местности.

Maksim7enov · 24.11.2023, 10:25

Поменял в строке 39 и 40

Код:

[Выделить все]

 (defun c:inserttablecoord (/ adoc ss1 ss2 cord n blk lstcordname i objtabl1 nametable)
  (setq adoc (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) ;_ end of vla-get-modelspace
  ) ;_ end ofsetq
  (while (not (setq ss1 (car (entsel "\nВыберите полилинию: ")))) (princ "\nMiss!"))
  (while (not (setq ss2 (car (entsel "\nВыберите блок: ")))) (princ "\nMiss!"))
  (setq nametable (getstring "\nВведите имя таблицы: "))
  (setq cord (fun-coordpolily (vlax-ename->vla-object ss1)))
  (setq n 1)
  (foreach q cord
    (setq blk (vla-insertblock adoc
                               (vlax-3d-point q)
                               (vla-get-effectivename (vlax-ename->vla-object ss2))
                               1
                               1
                               1
                               0
              ) ;_ end ofvla-InsertBlock
    ) ;_ end ofsetq
    (vla-put-textstring (car (_att_in_blk blk "НОМЕР_ВЕРШИНЫ")) (vl-princ-to-string n))
    (setq lstcordname (cons (cons n q) lstcordname))
    (setq n (1+ n))
  ) ;_ end offoreach
  (setq lstcordname (reverse lstcordname))
  (setq i 0)
  (setq objtabl1 (vla-addtable adoc
                               (vlax-3d-point (getpoint "\nУкажите точку вставки таблицы: ")) ;_ end of vlax-3d-point
                               (+ (length cord) 2)
                               3
                               8
                               30
                 ) ;_ end of vla-AddTable
  ) ;_ end of setq
  (vla-settext objtabl1 0 0 nametable)
  (vla-settext objtabl1 (+ i 1) 0 "Точка")
  (vla-settext objtabl1 (+ i 1) 1 "X")
  (vla-settext objtabl1 (+ i 1) 2 "Y")
  (while (< i (length cord))
    (vla-settext objtabl1 (+ i 2) 0 (vl-princ-to-string (car (nth i lstcordname)))) ;название точки
    (vla-settext objtabl1 (+ i 2) 2 (rtos (cadr (nth i lstcordname)) 2)) ;координата X
    (vla-settext objtabl1 (+ i 2) 1 (rtos (caddr (nth i lstcordname))2)) ;координата Y
    (setq i (1+ i))
  ) ;_ end of while
  (vla-setalignment objtabl1 1 acmiddlecenter)
  (vla-settextheight objtabl1 acdatarow 2.5)
  (vla-settextheight objtabl1 actitlerow 5)
) ;_ end ofdefun

(defun _att_in_blk (obj lsttag /)
  (cond ((not lsttag) (setq lsttag (list "*")))
        ((atom lsttag) (setq lsttag (list lsttag)))
  ) ;_ end of cond
  (vl-member-if '(lambda (x)
                   (apply 'wcmatch
                          (list (strcase (vla-get-tagstring x))
                                (apply 'strcat (mapcar '(lambda (str) (strcase (strcat str ","))) lsttag)) ;_ end of apply
                          ) ;_ end of cons
                   ) ;_ end of apply
                 ) ;_ end of lambda
                (vl-catch-all-apply
                  '(lambda ()
                     (append (vlax-invoke obj 'getattributes) (vlax-invoke obj 'getconstantattributes)) ;_ end of append
                   ) ;_ end of lambda
                ) ;_ end of vl-catch-all-apply
  ) ;_ end of vl-member-if
) ;_ end of defun


(defun fun-coordpolily (sels / cord n cordinate)
  (setq cord1 (vlax-safearray->list (vlax-variant-value (vla-get-coordinates sels))))
  (setq n 0)
  (cond ((= (vla-get-objectname sels) "AcDbPolyline")
         (setq vert (/ (length cord1) 2))
        )
        ((= (vla-get-objectname sels) "AcDb2dPolyline")
         (setq vert (/ (length cord1) 3))
        )
        (t nil)
  ) ;_ end ofcond
  (repeat vert
    (setq cordinate (cons (vlax-safearray->list (vlax-variant-value (vla-get-coordinate sels n))) cordinate))
    (setq n (1+ n))
  ) ;_ end ofrepeat
  (reverse cordinate)
) ;_ end ofdefun

pzu_gp · 23.01.2024, 11:54

Maksim7enov, боже, вы просто спаситель местных генпланистов.
А вы не подскажите, можно реализовать в рамках данного лиспа дополнительный функционал, а именно:
1. Чтобы таблица имела вид как на скрине.
2. Чтобы у каждой точки определялся также дирекционный угол, так как в поле будут строить именно по углу. Тоже на скрине пример
3. И последнее это расстояние от точки до точки. Тоже как в примере на скрине

Заранее спасибо за ответ!

Maksim7enov · 23.01.2024, 14:55

Углы не понятно как ставить, без них будет так. Проверяйте

Код:

[Выделить все]

 (defun c:inserttablecoord (/ adoc ss1 ss2 pt1 cord n i a objtabl1 blk)
  (setq adoc (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (while (not (setq ss1 (car (entsel "\nВыберите полилинию: ")))) (princ "\nMiss!"))
  (while (not (setq ss2 (car (entsel "\nВыберите блок: ")))) (princ "\nMiss!"))
  (setq pt1  (getpoint "\nУкажите точку вставки таблицы: ")
        cord (fun-coordpolily (vlax-ename->vla-object ss1))
        n    1
        i    0
        a    0
  ) ;_ end ofsetq
  (setq objtabl1 (vla-addtable adoc
                               (vlax-3d-point pt1) ;_ end of vlax-3d-point
                               (+ (* (length cord) 2) 3)
                               5
                               8
                               70
                 ) ;_ end of vla-AddTable
  ) ;_ end ofsetq

  (vla-settext objtabl1 0 0 "Ведомость вычисления площади земельного участка")
  (vla-settext objtabl1 (+ i 1) 0 "Название (номер) межевого знака")
  (vla-settext objtabl1 (+ i 1) 1 "Дирекционные углы (град. мин. сек.)")
  (vla-settext objtabl1 (+ i 1) 2 "Длина линии (м)")
  (vla-settext objtabl1 (+ i 1) 3 "X координата")
  (vla-settext objtabl1 (+ i 1) 4 "Y координата")
  
  (foreach q cord
    (setq blk (vla-insertblock adoc
                               (vlax-3d-point q)
                               (vla-get-effectivename (vlax-ename->vla-object ss2))
                               1
                               1
                               1
                               0
              ) ;_ end ofvla-InsertBlock
    ) ;_ end ofsetq
    (vla-put-textstring (car (_att_in_blk blk "НОМЕР_ВЕРШИНЫ")) (vl-princ-to-string n))
    (vla-settext objtabl1 (+ i 2) 0 (vl-princ-to-string (vl-princ-to-string n)))
    (vla-settext objtabl1 (+ i 2) 4 (rtos (car q) 2  3))
    (vla-settext objtabl1 (+ i 2) 3 (rtos (cadr q) 2 3))
    (setq i (1+ i))
    (if (< a (- (length cord) 1))
      (progn
        (vla-settext objtabl1 (+ i 2) 2 (rtos (distance (nth a cord) (nth (+ a 1) cord)) 2 2))
      ) ;_ end ofprogn
      (progn
       (vla-settext objtabl1 (+ i 3) 0 "1")
      (vla-settext objtabl1 (+ i 2) 2 (rtos (distance (nth a cord) (nth 0 cord)) 2 2))
      
          (vla-settext objtabl1 (+ i 3) 4 (rtos (caar cord) 2 3))
    (vla-settext objtabl1 (+ i 3) 3 (rtos (cadar cord) 2 3))
      )
    ) ;_ end ofif
    (setq n (1+ n)
          i (1+ i)
          a (1+ a)
    ) ;_ end ofsetq
  ) ;_ end offoreach
) ;_ end ofdefun


;Вспомогательное
(defun _att_in_blk (obj lsttag /)
  (cond ((not lsttag) (setq lsttag (list "*")))
        ((atom lsttag) (setq lsttag (list lsttag)))
  ) ;_ end of cond
  (vl-member-if '(lambda (x)
                   (apply 'wcmatch
                          (list (strcase (vla-get-tagstring x))
                                (apply 'strcat (mapcar '(lambda (str) (strcase (strcat str ","))) lsttag)) ;_ end of apply
                          ) ;_ end of cons
                   ) ;_ end of apply
                 ) ;_ end of lambda
                (vl-catch-all-apply
                  '(lambda ()
                     (append (vlax-invoke obj 'getattributes) (vlax-invoke obj 'getconstantattributes)) ;_ end of append
                   ) ;_ end of lambda
                ) ;_ end of vl-catch-all-apply
  ) ;_ end of vl-member-if
) ;_ end of defun

(defun fun-coordpolily (sels / cord n cordinate)
  (setq cord1 (vlax-safearray->list (vlax-variant-value (vla-get-coordinates sels))))
  (setq n 0)
  (cond ((= (vla-get-objectname sels) "AcDbPolyline")
         (setq vert (/ (length cord1) 2))
        )
        ((= (vla-get-objectname sels) "AcDb2dPolyline")
         (setq vert (/ (length cord1) 3))
        )
        (t nil)
  ) ;_ end ofcond
  (repeat vert
    (setq cordinate (cons (vlax-safearray->list (vlax-variant-value (vla-get-coordinate sels n))) cordinate))
    (setq n (1+ n))
  ) ;_ end ofrepeat
  (reverse cordinate)
) ;_ end ofdefun

pzu_gp · 23.01.2024, 15:47

Maksim7enov, а непонятно как ставить в каком плане? То есть непонятно как реализовать это в рамках лиспа?

Maksim7enov · 23.01.2024, 16:03

Нужен пример графический, чтобы можно было его померить и сравнить правильность выполнения и понимание как считать угол.

pzu_gp · 23.01.2024, 18:43

Maksim7enov, Понял вас. Во вложении файл с границами, по которой составлена таблица. По углам могут быть расхождения, так как изначально граница была не совсем правильно построена, но суть по этим границам понять можно. Если совсем коротко, то это угол от севера до следующей точки по часовой стрелке. Ниже прилагаю скрин.
А еще как в коде выше реализовать все так, чтобы можно было еще начальный номер указывать самому? Чтобы например начиналось не с 1, а с 20.
Спасибо за помощь!

Maksim7enov · 24.01.2024, 09:36

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

Код:

[Выделить все]

 (defun c:inserttablecoord (/ adoc ss1 ss2 pt1 cord ang n i a objtabl1 blk)
  (setq adoc (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (while (not (setq ss1 (car (entsel "\nВыберите полилинию: ")))) (princ "\nMiss!"))
  (while (not (setq ss2 (car (entsel "\nВыберите блок: ")))) (princ "\nMiss!"))
  (setq n     (getint "\nВведите начальный номер точки:")
        pt1   (getpoint "\nУкажите точку вставки таблицы: ")
        cord  (fun-coordpolily (vlax-ename->vla-object ss1))
        ang   (fun-angle-poy cord)
        i     0
        a     0
        start n
  ) ;_ end ofsetq
  (setq objtabl1 (vla-addtable adoc
                               (vlax-3d-point pt1) ;_ end of vlax-3d-point
                               (+ (* (length cord) 2) 3)
                               5
                               8
                               70
                 ) ;_ end of vla-AddTable
  ) ;_ end ofsetq

  (vla-settext objtabl1 0 0 "Ведомость вычисления площади земельного участка")
  (vla-settext objtabl1 (+ i 1) 0 "Название (номер) межевого знака")
  (vla-settext objtabl1 (+ i 1) 1 "Дирекционные углы (град. мин. сек.)")
  (vla-settext objtabl1 (+ i 1) 2 "Длина линии (м)")
  (vla-settext objtabl1 (+ i 1) 3 "X координата")
  (vla-settext objtabl1 (+ i 1) 4 "Y координата")

  (foreach q cord
    (setq blk (vla-insertblock adoc
                               (vlax-3d-point q)
                               (vla-get-effectivename (vlax-ename->vla-object ss2))
                               1
                               1
                               1
                               0
              ) ;_ end ofvla-InsertBlock
    ) ;_ end ofsetq
    (vla-put-textstring (car (_att_in_blk blk "НОМЕР_ВЕРШИНЫ")) (vl-princ-to-string n))
    (vla-settext objtabl1 (+ i 2) 0 (vl-princ-to-string (vl-princ-to-string n)))
    (vla-settext objtabl1 (+ i 2) 4 (rtos (car q) 2 3))
    (vla-settext objtabl1 (+ i 2) 3 (rtos (cadr q) 2 3))
    (setq i (1+ i))
    (if (< a (- (length cord) 1))
      (progn
        (vla-settext objtabl1 (+ i 2) 2 (rtos (distance (nth a cord) (nth (+ a 1) cord)) 2 2))

        (vla-settext objtabl1 (+ i 2) 1 (nth a ang))
      ) ;_ end ofprogn
      (progn
        (vla-settext objtabl1 (+ i 3) 0 (vl-princ-to-string start))

        (vla-settext objtabl1 (+ i 2) 1 (nth a ang))

        (vla-settext objtabl1 (+ i 2) 2 (rtos (distance (nth a cord) (nth 0 cord)) 2 2))
        (vla-settext objtabl1 (+ i 3) 4 (rtos (caar cord) 2 3))
        (vla-settext objtabl1 (+ i 3) 3 (rtos (cadar cord) 2 3))
      ) ;_ end ofprogn
    ) ;_ end ofif
    (setq n (1+ n)
          i (1+ i)
          a (1+ a)
    ) ;_ end ofsetq
  ) ;_ end offoreach
) ;_ end ofdefun


          ;Вспомогательное
(defun _att_in_blk (obj lsttag /)
  (cond ((not lsttag) (setq lsttag (list "*")))
        ((atom lsttag) (setq lsttag (list lsttag)))
  ) ;_ end of cond
  (vl-member-if '(lambda (x)
                   (apply 'wcmatch
                          (list (strcase (vla-get-tagstring x))
                                (apply 'strcat (mapcar '(lambda (str) (strcase (strcat str ","))) lsttag)) ;_ end of apply
                          ) ;_ end of cons
                   ) ;_ end of apply
                 ) ;_ end of lambda
                (vl-catch-all-apply
                  '(lambda ()
                     (append (vlax-invoke obj 'getattributes) (vlax-invoke obj 'getconstantattributes)) ;_ end of append
                   ) ;_ end of lambda
                ) ;_ end of vl-catch-all-apply
  ) ;_ end of vl-member-if
) ;_ end of defun

(defun fun-coordpolily (sels / cord n cordinate)
  (setq cord1 (vlax-safearray->list (vlax-variant-value (vla-get-coordinates sels))))
  (setq n 0)
  (cond ((= (vla-get-objectname sels) "AcDbPolyline")
         (setq vert (/ (length cord1) 2))
        )
        ((= (vla-get-objectname sels) "AcDb2dPolyline")
         (setq vert (/ (length cord1) 3))
        )
        (t nil)
  ) ;_ end ofcond
  (repeat vert
    (setq cordinate (cons (vlax-safearray->list (vlax-variant-value (vla-get-coordinate sels n))) cordinate))
    (setq n (1+ n))
  ) ;_ end ofrepeat
  (reverse cordinate)
) ;_ end ofdefun


(defun fun-angle-poy (vert / i ang an)
  (setq i 1)
  (foreach q vert
    (if (< i (- (length vert) 1))
      (setq ang (vl-string-translate "d" "°" (angtos (- (/ pi 2) (angle q (nth i vert))) 1 4)))
      (setq ang (vl-string-translate "d" "°" (angtos (- (/ pi 2) (angle q (nth 0 vert))) 1 4)))
    ) ;_ end ofif
    (setq an (cons ang an))
    (setq i (1+ i))
    (reverse an)
  ) ;_ end offoreach
) ;_ end ofdefun

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Создание таблицы SPDS БЕЗ автообсчета, используя таблицу с автообсчетом.	13Rossoneri	Прочее. Программное обеспечение	6	15.02.2014 13:43
Как уменьшить количество вершин в полилинии	Димас	AutoCAD	30	01.01.2014 21:53
координаты вершин выбранной полилинии на VB? как получить	ssv22	Программирование	5	17.07.2008 00:01
Изменение отметки Z вершин полилинии	Mazai	Программирование	5	27.05.2008 03:35
Удаление совпадающих вершин из полилинии	Кочетков Андрей	Программирование	28	18.07.2006 20:48