Тема: Список площадей выделенных полилиний в тектовое окно (файл)

Довольно давно добрый человек сбацал вещь, которая пытается расставлять площади по всем полилиниям слоя. Однако выяснилось что это нереально:
(defun C:breda()
(setq LN (getstring "nИмя слоя введи >"))
(setq NLST (tblnext "LAYER" T))
(setq LLST (list NLST))
(setq NLST (tblnext "LAYER"))
(while (not(= NLST nul))
(setq LLST (cons NLST LLST))
(setq NLST (tblnext "LAYER")))
(setq LLAY (list "0"))
(foreach NLST LLST(setq LLAY (cons (cdr(assoc 2 NLST)) LLAY)))
(while (= (member LN LLAY) nil)(subpr))
(setq A(ssget "_X" '((0 . "LWPOLYLINE") (70 . 1))))
(setq K (sslength A))
(setq NL 0
LP nil
)
(repeat K
(setq LP (cons (ssname A NL) LP))
(setq NL (+ 1 NL))
)
(foreach E LP
(setq SS (entget E))
(if (=(cdr(assoc 8 SS)) LN)
(progn(setq TI (cdr(assoc 10 SS)))
(setq X (+ 2 (car TI)))
(setq Y (+ 2 (car (reverse TI))))
(setq TI (list X Y))
(command "area" "o" E)
(setq T(getvar "area"))
(setq TC (itoa(fix T)))
(setq LON (+ 1(strlen TC)))
(setq TD (substr(itoa(fix(* T 10)))LON 1))
(setq T (strcat TC "." TD))
(command "text" TI "0" T)))
)
)
(defun subpr()
(setq LN (getstring "nНету слоя с таким именем. Правильно >"))
)
Пожалуста подравьте так, чтобы он это добро проставлял столбцом просто в тектовое окно или файл, для переноса в Excel.
Конечно хорошо бы чтобы объекты можно было выбрать контуром...
Или даже произвести операцию по нескольким слоям, указывая в тексте перед площадью линии имя слоя...
А бывает у полилинии атрибут, куда ей можно проставить ТЕКСТОВЫЙ идентификатор?
К сожалению сам в LISPе = 0, а реестры делать задолбался!
Заранее благодарен...

Re: Список площадей выделенных полилиний в тектовое окно (файл)

Ну попробуй, вроде как работает:

(defun c:areas (/ selset file_name file_handle *error*)
  (defun *error* (msg)
    (vl-catch-all-apply '(lambda () (close file_handle)))
    (princ msg)
    (princ)
    ) ;_ end of defun
  (if (and (setq selset (ssget '((0 . "*POLYLINE"))))
           (setq file_name (getfiled "Файл результата" "" "xls" 1))
           ) ;_ end of and
    (progn
      (setq file_handle (open file_name "w"))
      (write-line "Слой\tПлощадь элемента" file_handle)
      (foreach item
               (mapcar 'vlax-ename->vla-object
                       (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
                       ) ;_ end of mapcar
        (if (vlax-property-available-p item 'area)
          (write-line
            (strcat (vla-get-layer item)
                    "\t"
                    (vl-string-translate
                      "."
                      (vl-registry-read
                        "HKEY_CURRENT_USER\\Control Panel\\International"
                        "sDecimal"
                        ) ;_ end of vl-registry-read
                      (vl-princ-to-string (vla-get-area item))
                      ) ;_ end
                    ) ;_ end of strcat
            file_handle
            ) ;_ end of write-line
          ) ;_ end of if
        ) ;_ end of foreach
      (close file_handle)
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

Сразу в xls файл засовывает, площади в единицах файла. Первым столбцом - имя слоя.

Re: Список площадей выделенных полилиний в тектовое окно (файл)

Или так

(defun c:lArea (/ sel layer sel_pline file_name layer file)
  (if (setq sel (entsel "\nВыберите объект для указания имени слоя"))
    (progn
      (setq layer (vla-get-layer (vlax-ename->vla-object (car sel))))
      (if
    (setq
      sel_pline (ssget "_X"
               (list (cons 0 "LWPOLYLINE") (cons 8 layer))
            ) ;_ end_ssget
    ) ;_ end_setq
     (progn
       (if
         (setq file_name (GETFILEd "Cохранение файла" "" "csv" 33))
          (progn
        (if
          (setq file (open file_name "a"))
           (progn
             (WRITE-LINE layer file)
             (mapcar
               (function
             (lambda (x)
               (WRITE-LINE
                 (strcat
                   ";"
                   (rtos (vla-get-area
                       (vlax-ename->vla-object (cadr x))
                     ) ;_ end_vla-get-area
                   ) ;_ end_rtos
                 ) ;_ end_strcat
                 file
               ) ;_ end_WRITE-LINE
             ) ;_ end_lambda
               ) ;_ end_function
               (ssnamex sel_pline)
             ) ;_ end_mapcar
             (close file)
           ) ;_ end_progn
           (alert
             (strcat "Не удалось открыть файл"
                 file_name
                 "\nВозможно он используется другой программой"
             ) ;_ end_strcat
           ) ;_ end_alert
        ) ;_ end_progn
          ) ;_ end_progn
          (alert "Небыло указано имя файла")
       ) ;_ end_if
     ) ;_ end_progn
     (alert (strcat "Не найдено полилиний на слое " layer))
      ) ;_ end_if
    ) ;_ end_progn
    (alert "Ничего не выбрано")
  ) ;_ end_if
) ;_ end_defun

Re: Список площадей выделенных полилиний в тектовое окно (файл)

"Тетенька дайте воды попить, а то так есть хочется, что аж переночевать не с кем!"
Скрипт kpblc функционирует 100%, однако раньше я его переделывал на коленке и он у меня писал периметры (длины), а теперь незнаю к чему подступиться... пожалуйста, добавь колонку с длиной каждой полилинии.
Кстати идея! Если число площади ПЕРВОГО объекта > 100 000, можно все площади делить на 1000 000 значит единица милиметры а нужны м2, два знака после запятой... (Периметры на /1000). Анализировать каждый не стоит, т.к. может попасть какой нибудь мусор? Хотя у меня порядок, но если еще кто воспользуется...
Если меньше - не нужно, значит единица - метры. тоже 2 знака после запятой.  У меня бывают оба случая! Да и у людей я сантиметров-дециметров не встречал.
Конечно Excel все делит, но автоматом должно получиться очень элегантно.
Скрипт Serzh тоже работает, но выставляет ";" перед числом, как устранять? Я с басиком для экселя лет 5 не тренировался...
С текстовым идентификатором для полилиний я понял глухо? не бывает?

Re: Список площадей выделенных полилиний в тектовое окно (файл)

В Extended Dates каждой полилинии есть Notes, куда можно вбить подходящий идентификатор, но аналогичного Field, чтобы он высвечивался нет...
Может сделать отдельный скрипт, который вносит данные из имеющегося _dtext в этот Notes?
А в свою очередь areas kpblc® этот Notes тоже вносит в xls!

Re: Список площадей выделенных полилиний в тектовое окно (файл)

Значится так, я сегодня в оффлайне весь день, скорее всего, буду, поэтому минимум комментов (код на работоспособность не тестировал - попросту некогда):

(defun c:areas (/ selset file_name file_handle *error*)
  (defun *error* (msg)
    (vl-catch-all-apply '(lambda () (close file_handle)))
    (princ msg)
    (princ)
    ) ;_ end of defun
  (if (and (setq selset (ssget '((0 . "*POLYLINE"))))
           (setq file_name (getfiled "Файл результата" "" "xls" 1))
           ) ;_ end of and
    (progn
      (setq file_handle (open file_name "w"))
      [b](write-line "Слой\tПлощадь элемента\tПлощадь в кв.м.\tДлина полилинии, мм\tДлина, м" file_handle)[/b]
[b][i];|Здесь пишем заголовки столбцов|;[/i][/b]
      (foreach item
               (mapcar 'vlax-ename->vla-object
                       (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
                       ) ;_ end of mapcar
        (if (vlax-property-available-p item 'area)
[b][i];|Теперь собственно заполнение данными:|;[/i][/b]
          (write-line
            (strcat
[b][i];; Имя слоя:[/i][/b]
 (vla-get-layer item)
[b][i];; Символ перехода на след.столбец:[/i][/b]
                    "\t"
[b][i];|Имеющаяся площадь в ед.файла, приведенная к числовому виду для Excel'a|;[/i][/b]
                    (vl-string-translate
                      "."
                      (vl-registry-read
                        "HKEY_CURRENT_USER\\Control Panel\\International"
                        "sDecimal"
                        ) ;_ end of vl-registry-read
[b][i];|Преобразование в строку|;[/i][/b]
                      (vl-princ-to-string
[b][i];|Площади полилинии|;[/i][/b]
(vla-get-area item))
                      ) ;_ end
[b][i];; Символ перехода на след.столбец:[/i][/b]
                    "\t"
                    (vl-string-translate
                      "."
                      (vl-registry-read
"HKEY_CURRENT_USER\\Control Panel\\International"
                        "sDecimal"
                        ) ;_ end of vl-registry-read
[b][i];|Опять преобразование в строку|;[/i][/b]
                      (vl-princ-to-string (/ [b][i];|площади, деленной на 1000000|;[/i][/b](vla-get-area item) 1000000.))
                      )
[b][i];; Символ перехода на след.столбец:[/i][/b]
                    "\t"
                    (vl-string-translate
                      "."
                      (vl-registry-read
                        "HKEY_CURRENT_USER\\Control Panel\\International"
                        "sDecimal"
                        ) ;_ end of vl-registry-read
                      (vl-princ-to-string [b][i];|Теперь длина|;[/i][/b](vla-get-Length item))
                      )
                    "\t"
                    (vl-string-translate
                      "."
                      (vl-registry-read
                        "HKEY_CURRENT_USER\\Control Panel\\International"
                        "sDecimal"
                        ) ;_ end of vl-registry-read
                      (vl-princ-to-string[b][i];|Длина, деленная на 1000|;[/i][/b] (/ (vla-get-area item) 1000.))
                      )
                    ) ;_ end of strcat
            file_handle
            ) ;_ end of write-line
          ) ;_ end of if
        ) ;_ end of foreach
      (close file_handle)
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

Надеюсь, что при необходимости переделать код проблем не составит?
На самом деле можно код поукоротить, но я пока пас :(
А вот с текстовыми идентификаторами я что-то не очень допер... Extended Datas - это явно для какого-то вертикального решения ACAD'a (MDT / ADT / ABS). Если же имеются в виду расширенные данные, то как минимум надо знать имя приложения, на которое зарегистрированы данные. А также DXF группы, откуда извлекаются эти значения.
---
P.S. Все время забываю сказать: все мои рассуждения - сугубо ИМХО.

Re: Список площадей выделенных полилиний в тектовое окно (файл)

Вариант с экспортом в Excel. Экспортируются длины и площади с Акада и формулы для пересчета площадей. Меняй коэффициенты в столбце Kl - длина и Ks - площадь

(defun xls ( punto_datos header / *aplexcel* *books-colection*
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell)
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application")
  *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
  *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
  *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
  *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)
  *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_не использовать системные установки
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            ;_разделитель дробной и целой части
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          ;_разделитель тысяччей
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (car header)))(setq header (cdr header))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length punto_datos)(setq iz_listo (car punto_datos))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq punto_datos (cdr punto_datos))(setq col 1 row (1+ row)))
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
(defun c:AREAS (/ selset file_name  *error* retLst lst i)
(defun *error* (msg)(princ msg)(princ)) ;_ end of defun
 (if (setq selset (ssget '((0 . "*POLYLINE"))))(progn (setq i 1)
  (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
    (setq i (1+ i))
    (setq lst (list (1- i)
      (vla-get-layer item)             ;|Слой"|;
      (rtos(vla-get-Length item) 2 12) ;|Длина полилинии|;
      (rtos(vla-get-area item) 2 12)   ;|Площадь полилинии|;
      (strcat "=G2*C" (itoa i))        ;|Длина полилинии с коэфф|;
      (strcat "=H2*D" (itoa i))        ;|Площадь полилинии с коэфф|;
      (if (= i 2) 0.001 "")            ;|Коэфф пересчета в м|;
      (if (= i 2) 0.000001 "")))       ;|Коэфф пересчета в м2|;
  (setq retLst (append retLst (list lst))));_foreach
(xls retlst '("№" "Слой" "L в ACAD" "S в ACAD" "L, м" "S, м2" "Kl коэфф. длины" "Ks коэфф. площади"))))
(princ))(princ "\nНаберите AREAS в командной строке")

Re: Список площадей выделенных полилиний в тектовое окно (файл)

to  kpblc
В последнюю колонку в третий раз вносит площадь. :(
to VVA
Функционирует ОК. Но колонка № в данном случае малоприменима!
to kbplc&VVA
Конечно удалить 2-3 столбца из Excel легко, но где красота маневра?
Такой скрипт может пригодиться при обработке помещений и участков. Не деталей же и трубопроводов :).
Как результат требуются м2 и м. Units обычно м или мм.
Помещений меньше 0.2 м2 не бывает, участки больше 20 га большая редкость, и обрабатываются не ACAD!
Соотвестсвенно добавляя при занесении данных что-то вроде:
(if (> T 200000)(setq T(/ T 1000000))) для площади и в этом случае безусловно /1000 для длинны получаем законченный скрипт, без лишних столбцов!
Я бы сам, да не смыслю ни бельмеса, но с детства отличался некоторым занудством, а сейчас мне под 40 и результаты ужасны :)
to All
Что есть у полилинии Properties -> Extended Data -> Documentation -> Notes и можно ли его както использовать для простейшей идентификации?
Использовать блоки или database не могу, а хотелось бы как то по простому маркировать примитивы из _dtext типа "А001ф".
В этом случае подготовка реестров превратилась бы в песню :) И не только у меня :) :)

Re: Список площадей выделенных полилиний в тектовое окно (файл)

Конечно удалить 2-3 столбца из Excel легко, но где красота маневра?

Зачем удалять? Выделяешь столбец -> правая кнопка-> скрыть. Красота маневра как раз таки в том, что в столбце G2 или H2 поменял на нужное значение и получил резудьтат.

(if (> T 200000)(setq T(/ T 1000000)))

Как раз таки твоя специфика. Кто работает, например, в 100 масштабе впишет свой коэффициент и тоже получит м2.
Не забывай, что в Exele можно написать простейший мактос методом тыка. И жать одну кнопку, которая оформит лист.
Как пример скрытия столбцов A, C,D

Sub Макрос3()
' Макрос3 Макрос
' Макрос записан 29.11.2006 (Vladimir A. Azarko)
    Columns("A:I").Select
    Selection.Columns.AutoFit
    Columns("A:A").Select
    Selection.EntireColumn.Hidden = True
    Columns("C:D").Select
    Selection.EntireColumn.Hidden = True
End Sub

По поводу Properties -> Extended Data -> Documentation -> Notes. В каком меню или где ты находишь такую последовательность?

Re: Список площадей выделенных полилиний в тектовое окно (файл)

to VVA
Я же говорю занудство не дает покоя, понимаю, что и так хорошо! В Excele VBA писал еще в 96 достаточной сложности, но ничего поделать не могу кажется что по моему лучше будет.
У меня ADT2005 включенный как ACAD. Выбираю любой примитив (поли-, мультилиния, дуга etc.и даже блок ) жму Properties, там 2 закладки - Design, где все свойства и Extended Data где:
hiperlink
notes
reference documents
В Notes сохраняется (обычным вводом) любой текст для любого из объектов... А у Вас разве нет?? Вопрос можно ли его туда внести и достать LISPом

Re: Список площадей выделенных полилиний в тектовое окно (файл)

> iv
У меня нет ADT

С текстовым идентификатором для полилиний я понял глухо? не бывает?

Бывает. Предлагаю гиперссылку (hyperlinks)
Мы так у себя иногда поступаем

;https://www.caduser.ru/forum/topic31444.html
(defun xls ( punto_datos header Colhide / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26)
  TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
  Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application")
  *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
  *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
  *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
  *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)
  *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_не использовать системные установки
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            ;_разделитель дробной и целой части
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          ;_разделитель тысяччей
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (car header)))(setq header (cdr header))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length punto_datos)(setq iz_listo (car punto_datos))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq punto_datos (cdr punto_datos))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
      (strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell  'Columns))
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
      (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))
(vlax-put-property cols 'hidden 1)
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
(DEFUN mip-put-hyperlink ( ENAME URLDescription )
 (if (eq (type ENAME) 'ENAME)(setq ENAME (vlax-ename->vla-object ENAME)))
  (vla-add (vla-get-hyperlinks ENAME) "about:blank" URLDescription))            
(defun C:HYP ( / sset hyptxt)(vl-load-com)
(setq hyptxt (getstring t "\nОписание объекта <выход>"))
(setq hyptxt (VL-STRING-TRIM " " hyptxt))
(if (and (/= hyptxt "")(setq sset (ssget "_:L")))
 (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset))))
   (mip-put-hyperlink item hyptxt)))(princ))
(defun c:AREAS (/ selset file_name  *error* retLst lst i UrlDes are)
(defun *error* (msg)(princ msg)(princ)) ;_ end of defun
(vl-load-com)
 (if (setq selset (ssget '((0 . "*POLYLINE"))))(progn (setq i 1)
  (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
     (setq UrlDes "" i (1+ i))
(if (not (zerop(vla-get-Count (vla-get-Hyperlinks item))))
  (VL-CATCH-ALL-APPLY '(lambda()(setq UrlDes(vla-get-URLDescription(vla-item (vla-get-Hyperlinks item) 0))))))
    (setq lst (list
      (vla-get-layer item)                              ;|Слой"|;
      UrlDes                                            ;|Метка полилинии|;
      (rtos(vla-get-Length item) 2 12)                  ;|Длина полилинии|;
      (rtos(setq are(vla-get-area item)) 2 12)          ;|Площадь полилинии|;
      (strcat "=G2*C" (itoa i))                         ;|Длина полилинии с коэфф|;
      (strcat "=H2*D" (itoa i))                         ;|Площадь полилинии с коэфф|;
      (if (= i 2) (if (> are 200000.0) 0.001 1) "")     ;|Коэфф пересчета в м|;
      (if (= i 2) (if (> are 200000.0) 0.000001 1) "")));|Коэфф пересчета в м2|;
  (setq retLst (append retLst (list lst))));_foreach
(xls retlst '("Слой" "Описание" "L в ACAD" "S в ACAD" "L, м" "S, м2" "Kl коэфф. длины" "Ks коэфф. площади") '("C" "D" "G" "H"))))
(princ))(princ "\nНаберите AREAS или HYP в командной строке")

Здесь две команды: HYP - для задания идентификатора объектам AREAS - подсчет площади
Выводится слой, идентификатор (гиперссылка), длина и площадь из автокада,пересчитанные длина и площадь, коэффициенты пересчета. Ненужные столбцы скрываются. В данном случае скрываются столбцы C,D,G,H

Re: Список площадей выделенных полилиний в тектовое окно (файл)

Для ADT-шных примитивов эти вещи записываются в словари. Вроде как в 2005 сработало такое:

(defun getnote (/ ent res dict)
  (if (and (setq ent (car (entsel)))
           (cdr (assoc 360 (entget ent)))
           (setq dict (member '(3 . "AEC_TEXT_NOTE")
                              (entget (cdr (assoc 360 (entget ent))))
                              ) ;_ end of member
                 ) ;_ end of setq
           ) ;_ end of and
    (setq res
           (cdr (assoc
                  1
                  (entget (cdr (assoc 360 (member '(3 . "AEC_TEXT_NOTE") dict))))
                  ) ;_ end of assoc
                ) ;_ end of cdr
          ) ;_ end of setq
    (setq res "")
    ) ;_ end of if
  res
  ) ;_ end of defun

Re: Список площадей выделенных полилиний в тектовое окно (файл)

to VVA
Работает 100%! Но слегка раздражает глобус :)!
Что обидно этот Notes находится прямо под Hiperlink (в меню)! И намного удобнее - вводится многострочный текст, удобное меню без лишних прибамбасов и т.п.
А как посмотреть какие свойства есть у объекта кроме "URLDescription"?
Поиск не дал ничего вразумительного - не знаю ключевых слов.
to kpblc
не ясно как работает :(  ?

Re: Список площадей выделенных полилиний в тектовое окно (файл)

Ну как - запускаем (getnote), указываем на примитив, с которого надо взять Notes, и в результате получаем его Notes (если они были вообще сделаны). Это отдельный кусок, который можно после проверки работоспособности интегрировать в программу > VVA (2006-11-29 14:49:01).

Re: Список площадей выделенных полилиний в тектовое окно (файл)

to kpblc
Несмотря на
Command: _appload GetNote.LSP successfully loaded.
Отвечает:
Command: getnote
Unknown command "GETNOTE".  Press F1 for help.
:(
Под чистым AEC вообще ничего не грузится (да и не нужно)! А здесь такая фигня!
Может сначала попробовать загрузить LISPом? посмотреть где лежит? В принципе основная идея такая и была, чтоб один скрипт его вставлял из _dtext или _mtext, которые все равно присутствуют, а второй извлекал в таблицу для
анализа площадей\длинн\ кстати, тк получается достаточно универсально, можно оставить и hiperlink и добавить цвет и даже кому нибудь может пригодиться тип линии!

Re: Список площадей выделенных полилиний в тектовое окно (файл)

Запуск не

Command : getnote

а

Command : (getnote)

С другой стороны, этот код не предназначен для "прямого использования". Вот вариант (на 2005 сработало):

(defun xls (punto_datos     header          /               *aplexcel*
            *books-colection*               *excell-cells*  *new-book*
            *sheet#1*       *sheet-collection*              col
            iz_listo        row             cell
            )
  (setq *aplexcel*         (vlax-get-or-create-object "Excel.Application")
        *books-colection*  (vlax-get-property *aplexcel* "Workbooks")
        *new-book*         (vlax-invoke-method *books-colection* "Add")
        *sheet-collection* (vlax-get-property *new-book* "Sheets")
        *sheet#1*          (vlax-get-property *sheet-collection* "Item" 1)
        *excell-cells*     (vlax-get-property *sheet#1* "Cells")
        ) ;_ end of setq
  (vlax-put-property *aplexcel* "UseSystemSeparators" :vlax-false) ; _не
          ; использовать системные установки
  (vlax-put-property *aplexcel* "DecimalSeparator" ".")
          ; _разделитель дробной и целой части
  (vlax-put-property *aplexcel* "ThousandsSeparator" " ") ; _разделитель
          ; тысяччей
  (vla-put-visible *aplexcel* :vlax-true)
  (setq row 1
        col 1
        ) ;_ end of setq
  (if (null header)
    (setq header '("X" "Y" "Z"))
    ) ;_ end of if
  (repeat (length header)
    (vlax-put-property
      *excell-cells*
      "Item"
      row
      col
      (vl-princ-to-string (car header))
      ) ;_ end of vlax-put-property
    (setq header (cdr header))
    (setq col (1+ col))
    ) ;_ end of repeat
  (setq row 2
        col 1
        ) ;_ end of setq
  (repeat (length punto_datos)
    (setq iz_listo (car punto_datos))
    (repeat (length iz_listo)
      (vlax-put-property
        *excell-cells*
        "Item"
        row
        col
        (vl-princ-to-string (car iz_listo))
        ) ;_ end of vlax-put-property
      (setq iz_listo (cdr iz_listo)
            col      (1+ col)
            ) ;_ end of setq
      ) ;_ end of repeat
    (setq punto_datos (cdr punto_datos))
    (setq col 1
          row (1+ row)
          ) ;_ end of setq
    ) ;_ end of repeat
  (mapcar 'vlax-release-object
          (list *excell-cells*      *sheet#1*           *sheet-collection*
                *new-book*          *books-colection*   *aplexcel*
                ) ;_ end of list
          ) ;_ end of mapcar
  (setq *aplexcel* nil)
  (gc)
  (gc)
  (princ)
  ) ;_ end of defun
(defun getnote (item / ent res dict)
  (if (and (setq ent (vlax-vla-object->ename item))
           (cdr (assoc 360 (entget ent)))
           (setq dict (member '(3 . "AEC_TEXT_NOTE")
                              (entget (cdr (assoc 360 (entget ent))))
                              ) ;_ end of member
                 ) ;_ end of setq
           ) ;_ end of and
    (setq res
           (cdr (assoc
                  1
                  (entget (cdr (assoc 360 (member '(3 . "AEC_TEXT_NOTE") dict))))
                  ) ;_ end of assoc
                ) ;_ end of cdr
          ) ;_ end of setq
    (setq res "")
    ) ;_ end of if
  res
  ) ;_ end of defun
(defun c:areas (/ selset file_name *error* retlst lst i)
  (defun *error* (msg) (princ msg) (princ)) ;_ end of defun
  (if (setq selset (ssget '((0 . "*POLYLINE"))))
    (progn
      (setq i 1)
      (foreach item
               (mapcar 'vlax-ename->vla-object
                       (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
                       ) ;_ end of mapcar
        (setq i (1+ i))
        (setq lst (list (1- i)
                        (vla-get-layer item) ;|Слой"|;
                        (rtos (vla-get-length item) 2 12)
                        ;|Длина полилинии|;
                        (rtos (vla-get-area item) 2 12)
                        ;|Площадь полилинии|;
                        (strcat "=G2*C" (itoa i))
                        ;|Длина полилинии с коэфф|;
                        (strcat "=H2*D" (itoa i))
                        ;|Площадь полилинии с коэфф|;
                        (if (= i 2)
                          0.001
                          ""
                          ) ;_ end of if
                        ;|Коэфф пересчета в м|;
                        (if (= i 2)
                          0.000001
                          ""
                          ) ;_ end of if
                        ;|Notes|;
                        (cond ((getnote item))
                              (t "")
                              ) ;_ end of cond
                        ) ;_ end of list
              ) ;_ end of setq
        ;|Коэфф пересчета в м2|;
        (setq retlst (append retlst (list lst)))
        ) ;_foreach
      (xls retlst
           '("№"              "Слой"           "L в ACAD"
             "S в ACAD"       "L, м"           "S, м2"
             "Kl коэфф. длины"                 "Ks коэфф. площади"
             "Примечание"
             )
           ) ;_ end of xls
      ) ;_ end of progn
    ) ;_ end of if
  (princ)
  ) ;_ end of defun
(princ "\nНаберите AREAS в командной строке")

Re: Список площадей выделенных полилиний в тектовое окно (файл)

iv пишет:

Но слегка раздражает глобус :)!

Команда _HYPERLINKOPTIONS (ГИПЕРСВОЙСТВА)
kpblc использовал вариант c не нужным тебе №. Я модифицировал ф-цию xls (подробности в описании)
И свой последний код. Для выбора описания полилинии используется в порядке приоритета
1. Properties -> Extended Data -> Documentation -> Notes в ADT
2. Описание Гиперссылки
Проверить не могу. Но должно работать.

;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic31444.html
               https://www.caduser.ru/forum/topic31669.html
* Назначение: Печать списка данных punto_datos в Excell
*             Для вывода создается новая книга
              Вывод осуществляется в первом листе
* Аргументы:
              punto_datos - список списков данных (LIST) вида
                            ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                            Каждый список вида (Value1 Value2 ... VlalueN) записывается
                            в отдельную строку в соответствующие столбцы (Value1-A Value2-B и .т.д.)
                  header -  список (LIST) заголовков или nil вида ("Подпись A" "Подпись B" ...)
                            Если header nil, принимается ("X" "Y" "Z")
                 Colhide -  список буквенных названий стоблцов для скрытия или nil - не скрывать
                            ("A" "C" "D") - скрыть столбцы A, C, D
* Возврат: nil
* TIPS!!! : При передачи функции xls числовых вещественных данных нет необходимости проверять текущий системный
            разделитель целой и дробной части ("HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")
            Функцией на время вывода отключается использование в Excele системного разделителя, разделителем
            целой и дробной части устанавливается точка. После завершения ф-ции все восстанавливается.
Пример вызова
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Столбец1" "Столбец2" "Столбец3" "Столбец4") '("B"))
|;
(defun xls ( punto_datos header Colhide / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26)
  TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
  Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application")
  *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
  *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
  *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
  *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)
  *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_не использовать системные установки
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            ;_разделитель дробной и целой части
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          ;_разделитель тысяччей
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (car header)))(setq header (cdr header))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length punto_datos)(setq iz_listo (car punto_datos))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq punto_datos (cdr punto_datos))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
      (strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell  'Columns))
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
      (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))
(vlax-put-property cols 'hidden 1)
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
(DEFUN mip-put-hyperlink ( ENAME URLDescription )
 (if (eq (type ENAME) 'ENAME)(setq ENAME (vlax-ename->vla-object ENAME)))
  (vla-add (vla-get-hyperlinks ENAME) "about:blank" URLDescription))
(defun getnote (item / ent res dict)
  (if (and (setq ent (vlax-vla-object->ename item))(cdr (assoc 360 (entget ent)))
           (setq dict (member '(3 . "AEC_TEXT_NOTE")(entget (cdr (assoc 360 (entget ent)))))))
    (setq res (cdr (assoc 1 (entget (cdr (assoc 360 (member '(3 . "AEC_TEXT_NOTE") dict)))))))
    (setq res "")) res)
;|=============== Команда HYP ================================================
Заносит введенное описание объекта всем выбранным примитивам как гиперссылку
Включенеи/отключение показа гиперссылок см. команды
_HYPERLINKOPTIONS (ГИПЕРСВОЙСТВА)|;
(defun C:HYP ( / sset hyptxt)(vl-load-com)
(setq hyptxt (getstring t "\nОписание объекта <выход>"))
(setq hyptxt (VL-STRING-TRIM " " hyptxt))
(if (and (/= hyptxt "")(setq sset (ssget "_:L")))
 (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset))))
   (mip-put-hyperlink item hyptxt)))(princ))
;|=============== Команда AREAS ================================================
Выводит Слой, Описание, длинну, Площадь выбранных полилиний в Excel в соответствующие столбцы
В Excel выводятся длинны и площади в единицах Автокада (столбцы C,D) и коэффициенты пересчета
(столбцы G, H). Столбцы C,D,G,H скрываются. Коэффициент пересчета принимается так:
если площадь ПЕРВОЙ выбранной полилинии > 200000 ед. автокада, то коэффициент длины 0.001,
площади 0.000001. Иначе 1.
Для выбора описания полилинии используется в порядке приоритета
1. Properties -> Extended Data -> Documentation -> Notes в ADT
2. Описание Гиперссылки
_HYPERLINKOPTIONS (ГИПЕРСВОЙСТВА)|;
(defun c:AREAS (/ selset file_name  *error* retLst lst i UrlDes are)
(defun *error* (msg)(princ msg)(princ)) ;_ end of defun
(vl-load-com)
 (if (setq selset (ssget '((0 . "*POLYLINE"))))(progn (setq i 1)
  (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
     (setq UrlDes (getnote item) i (1+ i))
(if(and (= UrlDes "")(not (zerop(vla-get-Count (vla-get-Hyperlinks item)))))
  (VL-CATCH-ALL-APPLY '(lambda()(setq UrlDes(vla-get-URLDescription(vla-item (vla-get-Hyperlinks item) 0))))))
    (setq lst (list
      (vla-get-layer item)                              ;|Слой"|;
      UrlDes                                            ;|Notes полилинии|;
      (rtos(vla-get-Length item) 2 12)                  ;|Длина полилинии|;
      (rtos(setq are(vla-get-area item)) 2 12)          ;|Площадь полилинии|;
      (strcat "=G2*C" (itoa i))                         ;|Длина полилинии с коэфф|;
      (strcat "=H2*D" (itoa i))                         ;|Площадь полилинии с коэфф|;
      (if (= i 2) (if (> are 200000.0) 0.001 1) "")     ;|Коэфф пересчета в м|;
      (if (= i 2) (if (> are 200000.0) 0.000001 1) "")));|Коэфф пересчета в м2|;
  (setq retLst (append retLst (list lst))));_foreach
(xls retlst '("Слой" "Описание" "L в ACAD" "S в ACAD" "L, м" "S, м2" "Kl коэфф. длины" "Ks коэфф. площади") '("C" "D" "G" "H"))))
(princ))(princ "\nНаберите AREAS или HYP в командной строке")

Re: Список площадей выделенных полилиний в тектовое окно (файл)

to kpblc
Функционирует 100%. Выводится нужное поле! Раз показал недопустимую ошибку Excel, причина неясна...
to VVA
Функционирует 100%. Выводит то поле которое надо! Просьба не скрывать колонки в Excel.
to kpblc&VVA
Нашлось 100% применение для цвета, просьба добавить колонку!
Есть применение для hiperlink, просьба добавить ОТДЕЛЬНУЮ колонку!
Некоторая неприятность - запись вида "001" переделывает в 1 (вероятно Excel) как бы его превратить в текст? Сразу добавлять ' ??
Следование колонок (желательно :))Слой-Notes-площадь-длина-цвет-hiperlink
Опасность! если на слое  есть незамкнутая линия, те площадь = 0, может неправильно перемножать всё! Как ни странно у меня посчитал ее первой! Выход вижу в том чтобы проверять на >200 000 каждую линию, а вероятно лучше убрать предложенную мной проверку вообще (? :) ), т.к. округлять приходится все равно своей формулой и то что подходит для вставки текста не совсем годится для таблицы ;)...
И теперь окончательная доводка!
Как же Notes и Hiperlink заполнить из существующих _dtext или _mtext. Алгоритм вижу такой - команда (очередные две кнопочки :)) - выбор текста  - выбор объекта - автоматическое внесение данных.
Конечно хотелось бы чтобы в Notes можно было внести 2-3 _dtext, с автоматическим добавлением возвратов каретки... Тогда потребуется дополнительное нажатие пробела перед выбором объекта... Но это уж  как получится ...

Re: Список площадей выделенных полилиний в тектовое окно (файл)

> iv
1. Если цвет "ПОСЛОЮ" - выводить "ПОСЛОЮ" или цвет слоя на котором расположена?
2. Если цвет "ПОБЛОКУ" - ?
3. Если цвет RGB?
В следовании колонок не отражены площадь, длина из Акада и коэффициент
Может так
Слой- Notes- площадь- длина- цвет- hyperlink-
S,Acad- L,Acad- Ks- Kl
По поводу заполнения могу помочь только Dtext,Mtext ->Hyperlink

Re: Список площадей выделенных полилиний в тектовое окно (файл)

Цвет RGB примитива или номер цвета из Акада. Надпись "послою" не пойдет!
Я имел ввиду только площадь и длину из Акада!
Моё раннее предложение чревато ошибками, + все равно приходится округлять формулой в Экселе!
(В принципе если оставлять нужно делать ОКРУГЛ ВВЕРХ с 1 знаком после запятой)
Dtext,Mtext ->Hyperlink ОК!

Re: Список площадей выделенных полилиний в тектовое окно (файл)

Вроде как хотел. Цвет 0 -поблоку 256 - послою
Новая команда H2T

;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic31444.html
               https://www.caduser.ru/forum/topic31669.html
* Назначение: Печать списка данных punto_datos в Excell
*             Для вывода создается новая книга
              Вывод осуществляется в первом листе
* Аргументы:
              punto_datos - список списков данных (LIST) вида
                            ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                            Каждый список вида (Value1 Value2 ... VlalueN) записывается
                            в отдельную строку в соответствующие столбцы (Value1-A Value2-B и .т.д.)
                  header -  список (LIST) заголовков или nil вида ("Подпись A" "Подпись B" ...)
                            Если header nil, принимается ("X" "Y" "Z")
                 Colhide -  список буквенных названий стоблцов для скрытия или nil - не скрывать
                            ("A" "C" "D") - скрыть столбцы A, C, D
* Возврат: nil
* TIPS!!! : При передачи функции xls числовых вещественных данных нет необходимости проверять текущий системный
            разделитель целой и дробной части ("HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")
            Функцией на время вывода отключается использование в Excele системного разделителя, разделителем
            целой и дробной части устанавливается точка. После завершения ф-ции все восстанавливается.
Пример вызова
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Столбец1" "Столбец2" "Столбец3" "Столбец4") '("B"))
|;
(defun xls ( punto_datos header Colhide / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26)
  TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
  Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application")
  *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
  *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
  *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
  *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)
  *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_не использовать системные установки
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            ;_разделитель дробной и целой части
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          ;_разделитель тысяччей
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (car header)))(setq header (cdr header))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length punto_datos)(setq iz_listo (car punto_datos))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq punto_datos (cdr punto_datos))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
      (strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell  'Columns))
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
      (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))
(vlax-put-property cols 'hidden 1)
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
(DEFUN mip-put-hyperlink ( ENAME URLDescription )
 (if (eq (type ENAME) 'ENAME)(setq ENAME (vlax-ename->vla-object ENAME)))
  (vlax-for hyp (vla-get-hyperlinks ENAME)(vla-delete hyp))
  (vla-add (vla-get-hyperlinks ENAME) "about:blank" URLDescription))
(defun getnote (item / ent res dict)
  (if (and (setq ent (vlax-vla-object->ename item))(cdr (assoc 360 (entget ent)))
           (setq dict (member '(3 . "AEC_TEXT_NOTE")(entget (cdr (assoc 360 (entget ent)))))))
    (setq res (cdr (assoc 1 (entget (cdr (assoc 360 (member '(3 . "AEC_TEXT_NOTE") dict)))))))
    (setq res "")) res)
;|=============== Команда HYP ================================================
Заносит введенное описание объекта всем выбранным примитивам как гиперссылку
Включенеи/отключение показа гиперссылок см. команды
_HYPERLINKOPTIONS (ГИПЕРСВОЙСТВА)|;
(defun C:HYP ( / sset hyptxt)(vl-load-com)
(setq hyptxt (getstring t "\nОписание объекта <выход>"))
(setq hyptxt (VL-STRING-TRIM " " hyptxt))
(if (and (/= hyptxt "")(setq sset (ssget "_:L")))
 (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset))))
   (mip-put-hyperlink item hyptxt)))(princ))
;|=============== Команда AREAS ================================================
Выводит Слой, Описание, длинну, Площадь выбранных полилиний в Excel в соответствующие столбцы
_HYPERLINKOPTIONS (ГИПЕРСВОЙСТВА)|;
(defun c:AREAS (/ selset file_name  *error* retLst lst i UrlDes are Notes)
(defun *error* (msg)(princ msg)(princ)) ;_ end of defun
(vl-load-com)
 (if (setq selset (ssget '((0 . "*POLYLINE"))))(progn (setq i 1)
  (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
     (setq Notes (getnote item) i (1+ i) UrlDes "")
(if(not (zerop(vla-get-Count (vla-get-Hyperlinks item))))
  (VL-CATCH-ALL-APPLY '(lambda()(setq UrlDes(vla-get-URLDescription(vla-item (vla-get-Hyperlinks item) 0))))))
    (setq lst (list
      (strcat "'" (vla-get-layer item))                 ;|Слой"|;
      (if (= Notes "") "" (strcat "'" Notes))           ;|Notes полилинии|;
      (rtos(setq are(vla-get-area item)) 2 12)          ;|Площадь полилинии|;
      (rtos(vla-get-Length item) 2 12)                  ;|Длина полилинии|;
      (vla-get-color item)                              ;|Цвет полилинии|;
      (if (= UrlDes "") "" (strcat "'" UrlDes))         ;|Гиперссылка|;
      ))
  (setq retLst (append retLst (list lst))));_foreach
(xls retlst '("Слой" "Notes" "Площадь" "Длинна" "Цвет" "Гиперссылка") nil)))
(princ))(princ "\nНаберите AREAS или HYP в командной строке")
;|=============== Команда T2H ================================================
Заносит значение текстовых объектов как гиперссылку в вабранные объекты|;
(defun C:T2H (/ d obj ent adoc *error* undo lays Flag hyptxt sset)
  (defun *error* (msg)(vla-EndUndoMark adoc))
  (vl-load-com)(setq adoc (vla-get-activedocument (vlax-get-acad-object))
  lays (vla-get-layers adoc))(vla-StartUndoMark adoc)(setvar "CMDECHO" 0)
  (setq d (getvar "UNDOCTL"))
  (cond ((= d 0) (vl-cmdf "_.UNDO" "_All"))
    ((= d 3) (vl-cmdf "_.UNDO" "_Control" "_All"))
    (t nil)) ;_ end of cond
  (setq undo 0 Flag t)
  (initget "Undo Отмени Exit Выход _Undo Undo Exit Exit")
  (while Flag
    (setq obj (entsel (strcat "\n Выберите текст ["
           (if (not (zerop undo)) "Отмени/" "")
           "Выход] <выход>: ")))
    (cond ((= obj "Undo")(if (not (zerop undo))(progn
           (vl-cmdf "_UNDO" "_B")(setq undo (1- undo)))(alert "Нечего больше отменять")))
    ((= obj "Exit")(setq Flag nil))
    ((null obj)(if (= (getvar "ERRNO") 52)(setq Flag nil)(princ " *** Мимо ***")))
    (t (setq ent (vlax-ename->vla-object (car obj)))
     (cond ((= (vla-get-lock (vla-item lays (vla-get-layer ent))) :vlax-true)
      (alert "На блокированном слое!"))
     ((wcmatch (strcase(vla-get-ObjectName ent)) "*TEXT")
      (setq hyptxt (vla-get-textstring ent))(setq hyptxt (VL-STRING-TRIM " " hyptxt))
      (if (and (/= hyptxt "")
           (princ "\nЗначение гиперссылки <")(princ hyptxt)(princ ">")
           (setq sset (ssget "_:L")))(progn
     (vl-cmdf "_UNDO" "_M")(setq undo (1+ undo))
      (foreach item (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp(mapcar 'cadr(ssnamex sset))))
        (mip-put-hyperlink item hyptxt))
      )))
     (t (alert "Объект не текст")))))
   (initget "Undo Отмени Exit Выход _Undo Undo Exit Exit"))
 (vla-EndUndoMark adoc)(princ))
(princ "\nНаберите в командной строке T2H")

Re: Список площадей выделенных полилиний в тектовое окно (файл)

to VVA
Все функционирует как задумано :)
Кроме заполнения Notes... :(
to kpblc
Пожалуйста помоги заполнить поле Notes, если возможно из нескольких _dtext, через ВК!
to All
Не вредно ли ACADу загружать подобные функции постоянно или лучше только при вызове?

Re: Список площадей выделенных полилиний в тектовое окно (файл)

> Нашел
у сторителей Autodesk Bilding System, посмотрел Notes, вроде должно работать.
Здесь собрано все отсюда и отсюда https://www.caduser.ru/forum/topic19197.html
Текстируй

;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic31444.html
               https://www.caduser.ru/forum/topic31669.html
* Назначение: Печать списка данных punto_datos в Excell
*             Для вывода создается новая книга
              Вывод осуществляется в первом листе
* Аргументы:
              punto_datos - список списков данных (LIST) вида
                            ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                            Каждый список вида (Value1 Value2 ... VlalueN) записывается
                            в отдельную строку в соответствующие столбцы (Value1-A Value2-B и .т.д.)
                  header -  список (LIST) заголовков или nil вида ("Подпись A" "Подпись B" ...)
                            Если header nil, принимается ("X" "Y" "Z")
                 Colhide -  список буквенных названий стоблцов для скрытия или nil - не скрывать
                            ("A" "C" "D") - скрыть столбцы A, C, D
* Возврат: nil
* TIPS!!! : При передачи функции xls числовых вещественных данных нет необходимости проверять текущий системный
            разделитель целой и дробной части ("HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")
            Функцией на время вывода отключается использование в Excele системного разделителя, разделителем
            целой и дробной части устанавливается точка. После завершения ф-ции все восстанавливается.
Пример вызова
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Столбец1" "Столбец2" "Столбец3" "Столбец4") '("B"))
|;
(vl-load-com)
(defun xls ( punto_datos header Colhide / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26)
  TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
  Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application")
  *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
  *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
  *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
  *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)
  *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_не использовать системные установки
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            ;_разделитель дробной и целой части
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          ;_разделитель тысяччей
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (nth (1- col) header)))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length punto_datos)(setq iz_listo (car punto_datos))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq punto_datos (cdr punto_datos))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
      (strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell  'Columns))
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
      (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))
(vlax-put-property cols 'hidden 1)
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
(DEFUN mip-put-hyperlink ( ENAME URLDescription )
 (if (eq (type ENAME) 'ENAME)(setq ENAME (vlax-ename->vla-object ENAME)))
  (vlax-for hyp (vla-get-hyperlinks ENAME)(vla-delete hyp))
  (vla-add (vla-get-hyperlinks ENAME) "about:blank" URLDescription))
(defun getnote (item / ent res dict)
  (if (and (setq ent (vlax-vla-object->ename item))(cdr (assoc 360 (entget ent)))
           (setq dict (member '(3 . "AEC_TEXT_NOTE")(entget (cdr (assoc 360 (entget ent)))))))
    (setq res (cdr (assoc 1 (entget (cdr (assoc 360 (member '(3 . "AEC_TEXT_NOTE") dict)))))))
    (setq res "")) res)
(defun setnote ( ent new_note / dict edict lst aec_note xdic)
(setq xdic (vla-getextensiondictionary (vlax-ename->vla-object ent)))
(if (setq dict (cdr (assoc 360 (entget ent))))
  (setq edict (entget dict)))
(setq lst (list
        '(0 . "AEC_TEXT_NOTE")
        '(102 . "{ACAD_REACTORS")
        (cons 330 dict)
        '(102 . "}")
        (cons 330 dict)
        '(100 . "AecDbObject")
        '(102 . "{AEC_SUBOBJECT")
        '(300 . "AecImpObj")
        '(100 . "AecImpObj")
        '(3 . "")
        '(102 . "AEC_SUBOBJECT}")
        '(102 . "{AEC_NULLOBJECT}")
        '(100 . "AecDbTextNote")
        (cons 1 new_note)))
(if (setq new_note (entmakex lst))(progn
(if (setq aec_note(member '(3 . "AEC_TEXT_NOTE") edict))
  (progn
    (setq edict (vl-remove (car aec_note) edict))
    (setq edict (vl-remove (cadr aec_note) edict))))
(setq edict (append edict (list (cons 3 "AEC_TEXT_NOTE")(cons 360 new_note))))
(entmod edict)
(if (null (assoc 360 (entget ent)))
  (entmod (append (entget ent)(list(cons 360 dict))))))))
(defun Sum_Mline ( / SS ent vertex_list mline_length ret lay mline_tip)
(defun sum ( / found)(foreach item ret
 (if (and (= (strcase(car item))(strcase lay))
      (= (strcase(cadr item))(strcase mline_tip)))
 (setq found item)))
 (if found (setq ret (subst (list (nth 0 found)(nth 1 found)
 (+ (last found) mline_length)) found ret))
    (setq ret (append ret (list (list lay mline_tip mline_length))))))
(if (setq ss  (ssget (list (cons 0 "MLINE"))))
    (foreach item (vl-remove-if(function listp)(mapcar(function cadr)(ssnamex ss)))
      (setq ent (entget item))    
      (setq vertex_list (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= 11 (car x)))) ent)))
      (if (= 2 (logand 2 (cdr(assoc 71 ent))))(setq vertex_list (append vertex_list (list (car vertex_list)))))
      (setq mline_length (apply '+ (mapcar 'distance vertex_list (cdr vertex_list))))
      (setq mline_tip (cdr(assoc 2  ent)))(setq lay (cdr(assoc 8 ent))) (sum)))
 (setq ent ret ret nil)
 (foreach item ent (if (assoc (car item) ret)
   (setq ret (subst (append (assoc (car item) ret)(list(cdr item)))
             (assoc (car item) ret) ret))
   (setq ret (append ret (list(list (car item)(cdr item)))))))
 (setq ret (vl-sort ret '(lambda(x y)(< (car x)(car y)))))
 (setq ret (mapcar '(lambda(x)(list (car x)(vl-sort(cdr x) '(lambda(x y)(<(car x)(car y)))))) ret))
ret)
;|=============== Команда HYP ================================================
Заносит введенное описание объекта всем выбранным примитивам как гиперссылку
Включенеи/отключение показа гиперссылок см. команды
_HYPERLINKOPTIONS (ГИПЕРСВОЙСТВА)|;
(defun C:HYP ( / sset hyptxt)(vl-load-com)
(setq hyptxt (getstring t "\nОписание объекта <выход>: "))
(setq hyptxt (VL-STRING-TRIM " " hyptxt))
(if (and (/= hyptxt "")(setq sset (ssget "_:L")))
 (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset))))
   (mip-put-hyperlink item hyptxt)))(princ))
;|=============== Команда NOTE ================================================
Заносит введенное описание объекта всем выбранным примитивам как Notes|;
(defun C:NOTE ( / sset hyptxt)(vl-load-com)
(setq hyptxt (getstring t "\nОписание объекта <выход>: "))
(setq hyptxt (VL-STRING-TRIM " " hyptxt))
(if (and (/= hyptxt "")(setq sset (ssget "_:L")))
 (foreach item (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))
   (setnote item hyptxt)))(princ))
;|=============== Команда AREAS ================================================
Выводит Слой, Описание, длинну, Площадь выбранных полилиний в Excel в соответствующие столбцы
В Excel выводятся длинны и площади в единицах Автокада (столбцы C,D) и коэффициенты пересчета
(столбцы G, H). Столбцы C,D,G,H скрываются. Коэффициент пересчета принимается так:
если площадь ПЕРВОЙ выбранной полилинии > 200000 ед. автокада, то коэффициент длины 0.001,
площади 0.000001. Иначе 1.
Для выбора описания полилинии используется в порядке приоритета
1. Properties -> Extended Data -> Documentation -> Notes в ADT
2. Описание Гиперссылки
_HYPERLINKOPTIONS (ГИПЕРСВОЙСТВА)|;
(defun c:AREAS (/ selset file_name  *error* retLst lst i UrlDes are Notes)
(defun *error* (msg)(princ msg)(princ)) ;_ end of defun
(vl-load-com)
 (if (setq selset (ssget '((0 . "*POLYLINE"))))(progn (setq i 1)
  (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
     (setq Notes (getnote item) i (1+ i) UrlDes "")
(if(not (zerop(vla-get-Count (vla-get-Hyperlinks item))))
  (VL-CATCH-ALL-APPLY '(lambda()(setq UrlDes(vla-get-URLDescription(vla-item (vla-get-Hyperlinks item) 0))))))
    (setq lst (list
      (strcat "'" (vla-get-layer item))                 ;|Слой"|;
      (if (= Notes "") "" (strcat "'" Notes))           ;|Notes полилинии|;
      (rtos(setq are(vla-get-area item)) 2 12)          ;|Площадь полилинии|;
      (rtos(vla-get-Length item) 2 12)                  ;|Длина полилинии|;
      (vla-get-color item)                              ;|Цвет полилинии|;
      (if (= UrlDes "") "" (strcat "'" UrlDes))         ;|Гиперссылка|;
      ))
  (setq retLst (append retLst (list lst))));_foreach
(xls retlst '("Слой" "Notes" "Площадь" "Длинна" "Цвет" "Гиперссылка") nil)))
(princ))
(defun add_note ( note_func / d obj ent adoc *error* undo lays Flag hyptxt sset)
  (defun *error* (msg)(princ msg)(vla-EndUndoMark adoc))
  (vl-load-com)(setq adoc (vla-get-activedocument (vlax-get-acad-object))
  lays (vla-get-layers adoc))(vla-StartUndoMark adoc)(setvar "CMDECHO" 0)
  (setq d (getvar "UNDOCTL"))
  (cond ((= d 0) (vl-cmdf "_.UNDO" "_All"))
    ((= d 3) (vl-cmdf "_.UNDO" "_Control" "_All"))
    (t nil)) ;_ end of cond
  (setq undo 0 Flag t)
  (initget "Undo Отмени Exit Выход _Undo Undo Exit Exit")
  (while Flag
    (setq obj (entsel (strcat "\n Выберите текст ["
           (if (not (zerop undo)) "Отмени/" "")
           "Выход] <выход>: ")))
    (cond ((= obj "Undo")(if (not (zerop undo))(progn
           (vl-cmdf "_UNDO" "_B")(setq undo (1- undo)))(alert "Нечего больше отменять")))
    ((= obj "Exit")(setq Flag nil))
    ((null obj)(if (= (getvar "ERRNO") 52)(setq Flag nil)(princ " *** Мимо ***")))
    (t (setq ent (vlax-ename->vla-object (car obj)))
     (cond ((= (vla-get-lock (vla-item lays (vla-get-layer ent))) :vlax-true)
      (alert "На блокированном слое!"))
     ((wcmatch (strcase(vla-get-ObjectName ent)) "*TEXT")
      (setq hyptxt (vla-get-textstring ent))(setq hyptxt (VL-STRING-TRIM " " hyptxt))
      (if (and (/= hyptxt "")
           (princ "\nЗначение заметки <")(princ hyptxt)(princ ">")
           (setq sset (ssget "_:L")))(progn
     (vl-cmdf "_UNDO" "_M")(setq undo (1+ undo))
      (foreach item (vl-remove-if 'listp(mapcar 'cadr(ssnamex sset)))
        (eval (list note_func item hyptxt)))
      )))
     (t (alert "Объект не текст")))))
   (initget "Undo Отмени Exit Выход _Undo Undo Exit Exit"))
 (vla-EndUndoMark adoc)(princ))
;|=============== Команда T2N ================================================
Заносит значение текстовых объектов как Notes в вабранные объекты|;
(defun C:T2N ( )(add_note 'setnote))
;|=============== Команда T2HS ================================================
Заносит значение текстовых объектов как гиперссылку в вабранные объекты|;
(defun C:T2H ( )(add_note 'mip-put-hyperlink))
;;https://www.caduser.ru/forum/topic19197.html
;;Summ MLine
(defun c:SML (/ *error* retlst)
(defun *error* (msg)(princ msg)(princ)) ;_ end of defun
(vl-load-com)(setq retlst (Sum_Mline))
(setq retlst(mapcar '(lambda(x / lay)
         (setq lay (car x))
         (mapcar '(lambda(y)(cons lay y))
             (cadr x))) retlst))
(if (setq retlst (apply 'append retlst))
(xls retlst '("Слой" "ТИП" "Длина") nil)
(princ "\n ** Нет мультилиний **"))(princ))
(princ "\nНаберите в командной строке:")
(princ "\n\tSML - сумма мультилиний")
(princ "\n\tT2H - текст в гиперссылку")
(princ "\n\tT2N - текст в Notes (ADT)")
(princ "\n\tAREAS - площади полилиний")
(princ "\n\tHYP - задать гиперссылку объектам")
(princ "\n\tNote - задать Notes объектам")

Re: Список площадей выделенных полилиний в тектовое окно (файл)

to VVA
Note - работает как задумано! Из ком строки все попадает куда нужно!
Теперь необходимо чтобы Note, либо другой скрипт заполняли Notes из _dtext, _mtext и, при возможности, из нескольких _dtext (перед каждым, после первого добавлять пробел!).
Но и это еще не все! Перевод в Excel очень, очень удобен! Предлагаю добавить скрипт аналогичный blcx: https://www.caduser.ru/forum/topic11600.html
считающий все выбранные блоки и переводящий в Excel реестр по схеме:
Слой - Имя блока - Количество блоков данного типа на слое.

Re: Список площадей выделенных полилиний в тектовое окно (файл)

iv пишет:

Теперь необходимо чтобы Note, либо другой скрипт заполняли Notes из _dtext, _mtext и, при возможности, из нескольких _dtext (перед каждым, после первого добавлять пробел!).

А T2N-чего? Не попадает, что-ли?
Из нескольких dtext - неохота городить уже огороженный огород. Express txt2mtxt - соберет dtext' ты в МТЕКС, ну а потом T2N
По поводу блоков завтра подумаю