LISP. Подсчет длины линий на определенном слое (Страница 3 из 3)

Dextron3

Dextron3
Восстановленный участник

На форуме с 21 июня 2007г.
Сообщений: 27
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

Не поверите не могу найти применение данного лиспа, а что изолировние слоя и подсчет длинны изоляционных объектов отменили?

VVA

VVA
Активный участник

Откуда: Беларусь / Минск
На форуме с 29 марта 2006г.
Сообщений: 1,859
Спасибо: 26

Re: LISP. Подсчет длины линий на определенном слое

> AIF
Выдает ввиде таблицы в Excel

> Dextron3
А если подсчитать нужно на нескольких слоях (например длинны различных кабелей)?

;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic19920.html
               https://www.caduser.ru/forum/topic31444.html
               https://www.caduser.ru/forum/topic31669.html
* Автор: Владимир Азарко aka VVA
* Назначение: Печать списка данных Data-list в Excell
*             Для вывода создается новый лист
* Аргументы:
              Data-list — список списков данных (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
                 Name_list — имя нового листа активной книги или nil — новая книга
* Возврат: 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 ( Data-list header Colhide Name_list / *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)
(if (null Name_list)(setq Name_list ""))
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application"))
  (if (setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook"))
    (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
          *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
               *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add"))
(setq *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)))
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (if (= Name_list "")
                  (vl-filename-base(getvar "DWGNAME"))
                  (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
   col 0 cols nil)
(if (> (strlen Name_list) 26)
(setq Name_list (strcat (substr Name_list 1 10) "..." (substr Name_list (- (strlen Name_list) 13) 14))))
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)
(vlax-put-property *Sheet#1* 'Name Name_list)
(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 Data-list)(setq iz_listo (car Data-list))(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 Data-list (cdr Data-list))(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))
;_Команда MLEN41
(defun c:mlen41 (/ m ss clist temp)
  (defun sort (lst predicate)
    (mapcar '(lambda (x) (nth x lst)) (vl-sort-i lst predicate))
  )
  (defun combine (inlist is-greater is-equal / sorted current result)
    (setq sorted (sort inlist is-greater))
    (setq current (list (car sorted)))
    (foreach item (cdr sorted)
      (if (apply is-equal (list item (car current)))
  (setq current (cons item current))
  (progn
    (setq result (cons current result))
    (setq current (list item))
  )
      )
    )
    (cons current result)
  )
  (defun mlen4_1 (lst / sum_len)
    (setq sum_len 0)
    (foreach item (mapcar 'car lst)
      (setq
  sum_len  (+ sum_len
       (if (vlax-property-available-p item 'length)
         (vla-get-length item)
         (cond
           ((=
        (strcase (vla-get-objectname item) t)
        "acdbarc"
      ) ;_  =
      (vla-get-arclength item)
           )
           ((=
        (strcase (vla-get-objectname item) t)
        "acbcircle"
      ) ;_  =
      (* pi 2.0 (vla-get-radius item))
           )
           (t 0.0)
         ) ;_  cond
       ) ;_  if
    ) ;_  +
      )
    )
    (if  (not (zerop sum_len))
      (princ
  (strcat "\n\t" (cdar lst) " = " (rtos (* sum_len m) 2 4))
      )
    )
    (list (cdar lst)(rtos (* sum_len m) 2 4))
  )
  (vl-load-com)
  (and
    (setq m (getreal "\nвведите маштабный коэффициент:\t"))
    (setq ss (ssget "_:L"))
    (setq ss (mapcar
         (function vlax-ename->vla-object)
         (vl-remove-if
     (function listp)
     (mapcar
       (function cadr)
       (ssnamex ss)
     ) ;_  mapcar
         ) ;_ vl-remove-if
       )
    )
    (mapcar '(lambda (x)
         (setq temp (cons (cons x (vla-get-Layer x)) temp))
       )
      ss
    )
    (setq clist  (combine temp
       '(lambda (a b)
          (> (cdr a) (cdr b))
        )
       '(lambda (a b)
          (eq (cdr a) (cdr b))
        )
    )
    )
    (princ
      "\n\n  Общая длинна всех линейных примитивов по слоям:"
    )
    (setq temp (mapcar 'mlen4_1 clist))
    (xls temp '("Слой" "Длина") nil "mlen41")
  )
  (princ)
) ;_  defun

Команда MLEN41

Tayfun

Tayfun
Восстановленный участник

На форуме с 7 февраля 2006г.
Сообщений: 17
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

> VVA
а куда пишется результат работы лиспа ?
(очень хочу разобратся)
а тот вариант что создает ехель фаил ваще не работает :((

VVA

VVA
Активный участник

Откуда: Беларусь / Минск
На форуме с 29 марта 2006г.
Сообщений: 1,859
Спасибо: 26

Re: LISP. Подсчет длины линий на определенном слое

> Tayfun
В Excell

а тот вариант что создает ехель фаил ваще не работает :((

только что проверил, все работает.
Пиши на почту что и как ты делаешь по шагам

Tayfun

Tayfun
Восстановленный участник

На форуме с 7 февраля 2006г.
Сообщений: 17
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

> VVA
Владимир Плиз напиши пошагово что делать от загрузки до получения денных в екселе(на почту).
а линии должныбыть поли-линиями ?
просто линии тоже считает ?

Евгений Елпанов

Евгений Елпанов
Активный участник

Откуда: Москва
На форуме с 2 июля 2004г.
Сообщений: 2,538
Спасибо: 10

Re: LISP. Подсчет длины линий на определенном слое

> Tayfun
Как то не понятно, это вам нужно или VVA...

Tayfun

Tayfun
Восстановленный участник

На форуме с 7 февраля 2006г.
Сообщений: 17
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

это мне :)

off

off
Активный участник

Откуда: Ростов-на-Дону
На форуме с 24 июня 2006г.
Сообщений: 264
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

Если в строчке

(setq temp (cons (cons x (vla-get-Layer x)) temp))

Layer заменить на Linetype получим программу для подсчета длин линий разного типа (И слово Слой на Тип линии заменить). Удобно если ваши кабели сделаны каждый своим типом линии.
Пожелание:сделать значение масштабного коэффициента по умолчанию равным единице, и чтобы масштабный коэффициент запоминался и использовался при следующем вызове программы по умолчанию.

VVA

VVA
Активный участник

Откуда: Беларусь / Минск
На форуме с 29 марта 2006г.
Сообщений: 1,859
Спасибо: 26

Re: LISP. Подсчет длины линий на определенном слое

> off
C запоминанием масштаба

;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic19920.html
               https://www.caduser.ru/forum/topic31444.html
               https://www.caduser.ru/forum/topic31669.html
* Автор: Владимир Азарко aka VVA
* Назначение: Печать списка данных Data-list в Excell
*             Для вывода создается новый лист
* Аргументы:
              Data-list — список списков данных (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
                 Name_list — имя нового листа активной книги или nil — новая книга
* Возврат: 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 ( Data-list header Colhide Name_list / *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)
(if (null Name_list)(setq Name_list ""))
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application"))
  (if (setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook"))
    (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
          *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
               *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add"))
(setq *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)))
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (if (= Name_list "")
                  (vl-filename-base(getvar "DWGNAME"))
                  (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
   col 0 cols nil)
(if (> (strlen Name_list) 26)
(setq Name_list (strcat (substr Name_list 1 10) "..." (substr Name_list (- (strlen Name_list) 13) 14))))
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)
(vlax-put-property *Sheet#1* 'Name Name_list)
(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 Data-list)(setq iz_listo (car Data-list))(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 Data-list (cdr Data-list))(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))
;_Команда MLEN41
(defun c:mlen41 (/ m ss clist temp)
  (defun sort (lst predicate)
    (mapcar '(lambda (x) (nth x lst)) (vl-sort-i lst predicate))
  )
  (defun combine (inlist is-greater is-equal / sorted current result)
    (setq sorted (sort inlist is-greater))
    (setq current (list (car sorted)))
    (foreach item (cdr sorted)
      (if (apply is-equal (list item (car current)))
  (setq current (cons item current))
  (progn
    (setq result (cons current result))
    (setq current (list item))
  )
      )
    )
    (cons current result)
  )
  (defun mlen4_1 (lst / sum_len)
    (setq sum_len 0)
    (foreach item (mapcar 'car lst)
      (setq
  sum_len  (+ sum_len
       (if (vlax-property-available-p item 'length)
         (vla-get-length item)
         (cond
           ((=
        (strcase (vla-get-objectname item) t)
        "acdbarc"
      ) ;_  =
      (vla-get-arclength item)
           )
           ((=
        (strcase (vla-get-objectname item) t)
        "acbcircle"
      ) ;_  =
      (* pi 2.0 (vla-get-radius item))
           )
           (t 0.0)
         ) ;_  cond
       ) ;_  if
    ) ;_  +
      )
    )
    (if  (not (zerop sum_len))
      (princ
  (strcat "\n\t" (cdar lst) " = " (rtos (* sum_len m) 2 4))
      )
    )
    (list (cdar lst)(rtos (* sum_len m) 2 4))
  )
  (vl-load-com)
  (if (null *M*)(setq *M* 1))
  (initget 6)
  (and
    (princ "\nВведите маштабный коэффициент <")
    (princ *M*)(princ ">: ")
    (or (setq m (getreal))
    (setq m *M*)
    )
    (setq *M* m)
    (setq ss (ssget "_:L"))
    (setq ss (mapcar
         (function vlax-ename->vla-object)
         (vl-remove-if
     (function listp)
     (mapcar
       (function cadr)
       (ssnamex ss)
     ) ;_  mapcar
         ) ;_ vl-remove-if
       )
    )
    (mapcar '(lambda (x)
         (setq temp (cons (cons x (vla-get-Layer x)) temp))
       )
      ss
    )
    (setq clist  (combine temp
       '(lambda (a b)
          (> (cdr a) (cdr b))
        )
       '(lambda (a b)
          (eq (cdr a) (cdr b))
        )
    )
    )
    (princ
      "\n\n  Общая длинна всех линейных примитивов по слоям:"
    )
    (setq temp (mapcar 'mlen4_1 clist))
    (xls temp '("Слой" "Длина") nil "mlen41")
  )
  (princ)
) ;_  defun

Mikha

Mikha
Участник

На форуме с 5 февраля 2008г.
Сообщений: 37
Спасибо: 1

Re: LISP. Подсчет длины линий на определенном слое

Ссылка по теме:
http://dwg.ru/dnl/2733

Innkin

Innkin
Восстановленный участник

На форуме с 13 января 2009г.
Сообщений: 3
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

помогите пожалуйста!!очень надо..
написать программу создающую слой Size и переносящую все окружности на слой Size.создать слой Size, создать набор окружностей чертежа, заменить в каждом примитиве набора слой на новый.

СтройГеодезия

СтройГеодезия
Восстановленный участник

На форуме с 29 мая 2008г.
Сообщений: 30
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

За черчение Line, я бы руки отрывал.
От этих Line сплошные проблемы!!!!!!

VVA

VVA
Активный участник

Откуда: Беларусь / Минск
На форуме с 29 марта 2006г.
Сообщений: 1,859
Спасибо: 26

Re: LISP. Подсчет длины линий на определенном слое

> Innkin
Для таких просьб есть раздел LISP

VVA

VVA
Активный участник

Откуда: Беларусь / Минск
На форуме с 29 марта 2006г.
Сообщений: 1,859
Спасибо: 26

Re: LISP. Подсчет длины линий на определенном слое

Для подсчета площади по слоям на основе #59 Команда MAREA41

;_Команда MAREA41
(defun c:MAREA41 (/ m ss clist temp)
;https://www.caduser.ru/forum/topic20298.html
; Владимир Азарко aka VVA для caduser.ru
  (defun sort (lst predicate)
    (mapcar '(lambda (x) (nth x lst)) (vl-sort-i lst predicate))
  )
  (defun combine (inlist is-greater is-equal / sorted current result)
    (setq sorted (sort inlist is-greater))
    (setq current (list (car sorted)))
    (foreach item (cdr sorted)
      (if (apply is-equal (list item (car current)))
  (setq current (cons item current))
  (progn
    (setq result (cons current result))
    (setq current (list item))
  )
      )
    )
    (cons current result)
  )
  (defun mlen4_1 (lst / sum_area)
    (setq sum_area 0)
    (foreach item (mapcar 'car lst)
      (setq sum_area  (+ sum_area
       (if (vlax-property-available-p item 'area)
         (vla-get-area item)
         0
       ) ;_  if
    ) ;_  +
      )
    )
    (if  (not (zerop sum_area))
      (princ
  (strcat "\n\t" (cdar lst) " = " (rtos (* sum_area m) 2 4))
      )
    )
    (list (cdar lst)(rtos (* sum_area m) 2 4))
  )
  (vl-load-com)
  (if (null *M*)(setq *M* 1))
  (initget 6)
  (and
    (princ "\nВведите маштабный коэффициент <")
    (princ *M*)(princ ">: ")
    (or (setq m (getreal))
   (setq m *M*)
   )
    (setq *M* m)
    (setq ss (ssget "_:L"))
    (setq ss (mapcar
         (function vlax-ename->vla-object)
         (vl-remove-if
     (function listp)
     (mapcar
       (function cadr)
       (ssnamex ss)
     ) ;_  mapcar
         ) ;_ vl-remove-if
       )
    )
    (mapcar '(lambda (x)
         (setq temp (cons (cons x (vla-get-Layer x)) temp))
       )
      ss
    )
    (setq clist  (combine temp
       '(lambda (a b)
          (> (cdr a) (cdr b))
        )
       '(lambda (a b)
          (eq (cdr a) (cdr b))
        )
    )
    )
    (princ
      "\n\n  Общая площадь всех линейных примитивов по слоям:"
    )
    (setq temp (mapcar 'mlen4_1 clist))
    (xls temp '("Слой" "Площадь") nil "mlen41")
  )
  (princ)
) ;_  defun
;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic19920.html
               https://www.caduser.ru/forum/topic31444.html
               https://www.caduser.ru/forum/topic31669.html
* Автор: Владимир Азарко aka VVA
* Назначение: Печать списка данных Data-list в Excell
*             Для вывода создается новый лист
* Аргументы:
              Data-list — список списков данных (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
                 Name_list — имя нового листа активной книги или nil — новая книга
* Возврат: 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 ( Data-list header Colhide Name_list / *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)
(if (null Name_list)(setq Name_list ""))
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application"))
  (if (setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook"))
    (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
          *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
               *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add"))
(setq *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)))
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (if (= Name_list "")
                  (vl-filename-base(getvar "DWGNAME"))
                  (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
   col 0 cols nil)
(if (> (strlen Name_list) 26)
(setq Name_list (strcat (substr Name_list 1 10) "..." (substr Name_list (- (strlen Name_list) 13) 14))))
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)
(vlax-put-property *Sheet#1* 'Name Name_list)
(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 Data-list)(setq iz_listo (car Data-list))(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 Data-list (cdr Data-list))(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))

evg76

evg76
Участник

На форуме с 18 августа 2009г.
Сообщений: 7
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

классня вещь ! но есть маленкий недочет - считает и не замкнутые контура - что не есть хорошо.

VVA

VVA
Активный участник

Откуда: Беларусь / Минск
На форуме с 29 марта 2006г.
Сообщений: 1,859
Спасибо: 26

Re: LISP. Подсчет длины линий на определенном слое

Модификация из #64 для подсчета ЗАМНКУТЫХ контуров
Пояснение для полилиний:
Полилиния будет считаться замкнутой, если установлено соответствующее свойство или
совпадают начальная и конечная точка с точностью до 1e-6.

;_Команда MAREA42
(defun c:MAREA42 (/ m ss clist temp)
;_Считает площади ЗАМКНУТЫХ контуров  
;https://www.caduser.ru/forum/topic20298.html
; Владимир Азарко aka VVA для caduser.ru
  (defun sort (lst predicate) 
    (mapcar '(lambda (x) (nth x lst)) (vl-sort-i lst predicate)) 
  ) 
  (defun combine (inlist is-greater is-equal / sorted current result) 
    (setq sorted (sort inlist is-greater)) 
    (setq current (list (car sorted))) 
    (foreach item (cdr sorted) 
      (if (apply is-equal (list item (car current))) 
  (setq current (cons item current)) 
  (progn 
    (setq result (cons current result)) 
    (setq current (list item)) 
  ) 
      ) 
    ) 
    (cons current result) 
  ) 
  (defun mlen4_1 (lst / sum_area) 
    (setq sum_area 0) 
    (foreach item (mapcar 'car lst) 
      (setq sum_area  (+ sum_area 
       (if (and
         (vlax-property-available-p item 'area)
         (or
           (vlax-curve-isClosed item)
           (equal
         (vlax-curve-getStartPoint item)
         (vlax-curve-getEndPoint item)
         1e-6
         )
           )
         )
         (vla-get-area item) 
         0 
       ) ;_  if 
    ) ;_  + 
      ) 
    ) 
    (if  (not (zerop sum_area)) 
      (princ 
  (strcat "\n\t" (cdar lst) " = " (rtos (* sum_area m) 2 4)) 
      ) 
    ) 
    (list (cdar lst)(rtos (* sum_area m) 2 4)) 
  ) 
  (vl-load-com) 
  (if (null *M*)(setq *M* 1)) 
  (initget 6) 
  (and 
    (princ "\nВведите маштабный коэффициент <") 
    (princ *M*)(princ ">: ") 
    (or (setq m (getreal)) 
   (setq m *M*) 
   ) 
    (setq *M* m) 
    (setq ss (ssget "_:L")) 
    (setq ss (mapcar 
         (function vlax-ename->vla-object) 
         (vl-remove-if 
     (function listp) 
     (mapcar 
       (function cadr) 
       (ssnamex ss) 
     ) ;_  mapcar 
         ) ;_ vl-remove-if 
       ) 
    ) 
    (mapcar '(lambda (x) 
         (setq temp (cons (cons x (vla-get-Layer x)) temp)) 
       ) 
      ss 
    ) 
    (setq clist  (combine temp 
       '(lambda (a b) 
          (> (cdr a) (cdr b)) 
        ) 
       '(lambda (a b) 
          (eq (cdr a) (cdr b)) 
        ) 
    ) 
    ) 
    (princ 
      "\n\n  Общая площадь всех линейных примитивов по слоям:" 
    ) 
    (setq temp (mapcar 'mlen4_1 clist)) 
    (xls temp '("Слой" "Площадь") nil "mlen41") 
  ) 
  (princ) 
) ;_  defun 
;|================== XLS ======================================== 
* Опубликовано https://www.caduser.ru/forum/topic19920.html 
               https://www.caduser.ru/forum/topic31444.html 
               https://www.caduser.ru/forum/topic31669.html 
* Автор: Владимир Азарко aka VVA 
* Назначение: Печать списка данных Data-list в Excell 
*             Для вывода создается новый лист 
* Аргументы: 
              Data-list — список списков данных (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 
                 Name_list — имя нового листа активной книги или nil — новая книга 
* Возврат: 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 ( Data-list header Colhide Name_list / *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) 
(if (null Name_list)(setq Name_list "")) 
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application")) 
  (if (setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook")) 
    (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks") 
          *Sheet-Collection* (vlax-get-property *New-Book* "Sheets") 
               *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add")) 
(setq *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))) 
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells")) 
(setq Name_list (if (= Name_list "") 
                  (vl-filename-base(getvar "DWGNAME")) 
                  (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list)) 
   col 0 cols nil) 
(if (> (strlen Name_list) 26) 
(setq Name_list (strcat (substr Name_list 1 10) "..." (substr Name_list (- (strlen Name_list) 13) 14)))) 
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols))) 
(setq row Name_list) 
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")"))) 
(setq Name_list row) 
(vlax-put-property *Sheet#1* 'Name Name_list) 
(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 Data-list)(setq iz_listo (car Data-list))(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 Data-list (cdr Data-list))(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))

evg76

evg76
Участник

На форуме с 18 августа 2009г.
Сообщений: 7
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

СПАСИБО огромное очень помогло в работе.А можно ли слегка его усовершенствовать путем выбора 1контура внутри которого бы распологались полилинии на различных слоях?

VVA

VVA
Активный участник

Откуда: Беларусь / Минск
На форуме с 29 марта 2006г.
Сообщений: 1,859
Спасибо: 26

Re: LISP. Подсчет длины линий на определенном слое

А ничего усовершенствовать не нужно
1. Берем отсюда LISP.Выделение объектов в области контура или отсюда Выделение объектов в области контура, AutoCAD команды SCWP или SCCP
2. Выделяем и их помощью объекты внутри контура
3. Используем MAREA42
[FONT=Arial]!!! Обращаем внимание на то, что системная переменная PICKFIRST должна быть = 1[/FONT]

evg76

evg76
Участник

На форуме с 18 августа 2009г.
Сообщений: 7
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

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

evg76

evg76
Участник

На форуме с 18 августа 2009г.
Сообщений: 7
Спасибо: 0

Re: LISP. Подсчет длины линий на определенном слое

порывшись на форуме нашел вот это (http://forum.dwg.ru/showthread.php?p=98053#post98053) пост 8 это почти про меня. изменилось ли что с 2008 года?

LISP. Подсчет длины линий на определенном слое (Страница 3 из 3)

Сообщения с 51 по 70 из 70

#51 Ответ от Dextron3 8 сентября 2007г. 10:29:59

Re: LISP. Подсчет длины линий на определенном слое

#52 Ответ от VVA 10 сентября 2007г. 13:39:35

Re: LISP. Подсчет длины линий на определенном слое

#53 Ответ от Tayfun 21 сентября 2007г. 12:39:55

Re: LISP. Подсчет длины линий на определенном слое

#54 Ответ от VVA 21 сентября 2007г. 13:12:42

Re: LISP. Подсчет длины линий на определенном слое

#55 Ответ от Tayfun 21 сентября 2007г. 15:09:07

Re: LISP. Подсчет длины линий на определенном слое

#56 Ответ от Евгений Елпанов 21 сентября 2007г. 16:09:49

Re: LISP. Подсчет длины линий на определенном слое

#57 Ответ от Tayfun 24 сентября 2007г. 07:25:31

Re: LISP. Подсчет длины линий на определенном слое

#58 Ответ от off 13 декабря 2007г. 15:08:25

Re: LISP. Подсчет длины линий на определенном слое

#59 Ответ от VVA 13 декабря 2007г. 16:37:25

Re: LISP. Подсчет длины линий на определенном слое

#60 Ответ от Mikha 5 февраля 2008г. 09:18:19

Re: LISP. Подсчет длины линий на определенном слое

#61 Ответ от Innkin 13 января 2009г. 21:57:39

Re: LISP. Подсчет длины линий на определенном слое

#62 Ответ от СтройГеодезия 13 января 2009г. 23:50:15

Re: LISP. Подсчет длины линий на определенном слое

#63 Ответ от VVA 14 января 2009г. 09:40:05

Re: LISP. Подсчет длины линий на определенном слое

#64 Ответ от VVA 29 ноября 2012г. 13:06:40 (изменено: Владимир Азарко, 2 декабря 2012г. 11:57:24)

Re: LISP. Подсчет длины линий на определенном слое

#65 Ответ от evg76 1 декабря 2012г. 22:22:25

Re: LISP. Подсчет длины линий на определенном слое

#66 Ответ от VVA 2 декабря 2012г. 11:55:58 (изменено: Владимир Азарко, 2 декабря 2012г. 12:00:38)

Re: LISP. Подсчет длины линий на определенном слое

#67 Ответ от evg76 5 декабря 2012г. 00:03:14

Re: LISP. Подсчет длины линий на определенном слое

#68 Ответ от VVA 16 января 2013г. 09:29:10 (изменено: Владимир Азарко, 16 января 2013г. 09:29:48)

Re: LISP. Подсчет длины линий на определенном слое

#69 Ответ от evg76 16 января 2013г. 20:25:11 (изменено: Evgeniy Leschev, 16 января 2013г. 20:33:54)

Re: LISP. Подсчет длины линий на определенном слое

#70 Ответ от evg76 16 января 2013г. 20:56:57 (изменено: Evgeniy Leschev, 16 января 2013г. 20:58:19)

Re: LISP. Подсчет длины линий на определенном слое

Сообщения с 51 по 70 из 70

Тему читают: 1 гость

Вход на форум «Форумы CADUser»x

Ссылки