[ilka_t]

Подскажити где можно скачать или поделитись если у кого есть такое.

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

Okonechnikov A.N.
FOCAL V1.0

[Dima]

А куда намылить?

[ilka_t]

ilka_T@mail.ru

[{Smirnoff}]

Если только для отрезков, то вот простая щелкалка:

Код:

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

(defun c:llen (/ ent_set sum_len cur_ent vla_obj obj_dump len)
  (setvar "cmdecho" 0)
  (vl-load-com)
  (setq ent_set (ssadd))
  (setq sum_len 0.0)
  (while T
    (setq cur_ent (car(entsel "Select Line: ")))
    (if (= cur_ent nil)(alert "Nothing entity selected!"))
    (sssetfirst nil (ssadd cur_ent ent_set))
    (setq vla_obj (vlax-ename->vla-object cur_ent))
    (if(= T (vlax-property-available-p vla_obj "Length"))
      (progn 
      (setq len (vla-get-length vla_obj)
 	    sum_len (+ sum_len len))
      );end progn
      (progn
      (ssdel cur_ent ent_set)
      (alert "Selected entity is not Line!")
      );end progn
      );end if
    (terpri)
    (princ (strcat "**** Sum length="(rtos sum_len)" ****"))
    (terpri)
    );end while
  (princ)
  )

[Сметанка]

http://www.prodtp.ru/modules.php?op=...ownload&sid=22

[ilka_t]

Спасибо....

[Grinzaid]

Нашёл у себя такой лиспик:

Код:

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

(defun C:SUMLINES ()
(setq total 0)

(setq p nil)
(gc)

(prompt "\nSelect the lines you want to sum the lengths of: ")
(setq p (ssget))
(if p 
   (progn
     (setq n (sslength p))
     (setq l 0)
       (while (< l n)
           (if (= "LINE" (cdr (assoc 0 (setq elist (entget (ssname p l))))))
              (progn
                (setq start (cdr (setq as (assoc 10 elist))))
                (setq finish (cdr (setq as (assoc 11 elist))))
                (setq delta (distance start finish))
                (grdraw start finish -1)
                (setq total (+ total delta))
                (grtext -2 (strcat "Total: " (rtos total)))
              )
           )
            (setq l (1+ l))
          )
    )  
)
(print)
(write-line (strcat "Variable TOTAL has the sum of the length of the lines: " (rtos total)))
(graphscr)
)

[kos]

А вот и еще... http://www.autocad.ru/docs/doc_3098.htm
Подсчитывает общую длину указанных примитивов (не только линий, но полилиний, дуг и т.д.).
Впрочем приведу код здесь:

Код:

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

(vl-load-com)
(defun entLen (/ set:OfEnts int:l rea:LengthOfEnts)
  (setq  set:OfEnts (ssget)
  int:l 0
  rea:LengthOfEnts
   0.0
  ) ;_ setq
  (while (< int:l (sslength set:OfEnts))
    (setq rea:LengthOfEnts
     (+ rea:LengthOfEnts
        (vlax-curve-getDistAtParam
    (vlax-ename->vla-object (ssname set:OfEnts int:l))
    (vlax-curve-getEndParam (ssname set:OfEnts int:l))
        ) ;_ vlax-curve-getDistAtParam
     ) ;_ +
    ) ;_ setq
    (setq int:l (1+ int:l))
  ) ;_ while
  (princ (strcat "\nПримитивов: - "
     (itoa (sslength set:OfEnts))
     "\nОбщая длина: - "
     (rtos rea:LengthOfEnts)
   ) ;_ strcat
  ) ;_ princ
  (prin1)
) ;_ defun

[ilka_t]

Всем спасибо

[Геннадий aka PG]

http://cadhlp.kulichki.com/pg2/focall.zip

[{Smirnoff}]

Браво! На примере Kos, видно отличие ЛИСП-программиста, от нас ЛИСП-любителей... :?

[kos]

Сообщение от Fantomas Браво! На примере Kos, видно отличие ЛИСП-программиста, от нас ЛИСП-любителей... :?

Заблуждение. Я тоже любитель, только с большим стажем...

Модератору (или кто там за это отвечает): зачем прикрепили эту тему? Если кому нужно и интересно - есть поиск. С прикрепленными темами - перебор (ИМХО). Я в них даже не лажу (может и зря), надоедает читать одно и то же...

[lee]

Поддерживаю kos. С закрепленными темами перебор

Здравствуйте.
Я не лисп-программист, хотя что за штака такая - знаю. Сохранил текст в файл *.lsp, запустил через ap. .. а какой командой каоькулятор-то запускать?
в тексте не нашел

[vk]

Найдите (defun и гляньте, что написано дальше....

Если нечто вроде (defun entLen .... - то для запуска нужно набрать в командной строке (entLen) - именно так, со скобками, хотя регистр символов не имеет значения.

Если нечто вроде (defun C:SUMLINES .... - то для запуска нужно набрать в командной строке SUMLINES - без скобок

Если Вы имели в виду что то другое - то уточните проблему

Спасибо vk

[Vova]

Kos> Твой лисп почти не имеет изъянов. Кроме одного. Если в Selection set попадает, например, блок, то он ругается и не желает считать. Получается, что надо специально готовить экран для работы программы. Поясню на своем примере. На плане этажа в разных направлениях проходят, огибая препятствия, множество труб для электричества, закладываемых в бетон перекрытия. Трубы нескольких диаметров и заканчиваются они кружком, полым или сплошным, показывающим куда выводить конец трубы-вверх или вниз. Эти кружки-блоки. Каждый диаметр расположен в своем слое. Итак, надо подсчитать погонную длину, например, труб диам. 1 дюйм. Выделяю этот слой и получаю здесь линии, дуги и блоки. Далее, прежде чем применить лисп для подсчета суммарной длины (а это можно сделать рамкой всего за 2 щелчка) надо временно удалить блоки. (А в другом случае надо и другие детали удалять). Можно ли сделать так, чтобы программа игнорировала все, что она не умеет считать и выдавала бы сообщение: я подсчитала сумму того и сяго only!

[kos]

Сообщение от Vova Kos> Твой лисп почти не имеет изъянов. Кроме одного.

Неправда. Можно накопать гораздо больше. При желании. Потому что это не законченный продукт, а заготовка.

Сообщение от Vova Если в Selection set попадает, например, блок, то он ругается и не желает считать.

Да, обсчитываются только примитивы, подпадающие под определение "курва" (curve). Т.е. линейные примимтивы. Блок к ним не относится.

Сообщение от Vova Можно ли сделать так, чтобы программа игнорировала все, что она не умеет считать и выдавала бы сообщение: я подсчитала сумму того и сяго only!

Можно. Но не сейчас. Я в отпуске, на работу уже два дня хожу по _крайней необходимости_. Надеюсь, что завтра уже этой необходимости не будет.

И я буду 8)

[kos]

Ну, вот отпуск и кончился...

Код:

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

(vl-load-com)
(defun entLen ( / set:entities int:allEntities int:curveEntities int:l rea:length)
  (setq set:entities (ssget))
  (if set:entities
    (progn
      (setq int:allEntities (sslength set:entities)	; количество выбранных примитивов
	    int:curveEntities 0				; счетчик линейных примитивов
	    int:l 0					; счетчик
	    rea:length 0.0				; общая длина линейных примитивов
      ) ;_  setq
      (while (< int:l (sslength set:entities))
	(if (not
	      (vl-catch-all-error-p
		(vl-catch-all-apply
		  'vlax-curve-getStartPoint
		  (list (vlax-ename->vla-object (ssname set:entities int:l)))
		) ;_  vl-catch-all-apply
	      ) ;_  vl-catch-all-error-p
	    ) ;_  not
	  (setq	int:curveEntities (1+ int:curveEntities)
		rea:length	  (+ rea:length
				     (vlax-curve-getDistAtParam
				       (vlax-ename->vla-object (ssname set:entities int:l))
				       (vlax-curve-getEndParam (ssname set:entities int:l))
				     ) ;_  vlax-curve-getDistAtParam
				  ) ;_  +
	  ) ;_  setq
	) ;_  if
	(setq int:l (1+ int:l))
      ) ;_  while
      (princ (strcat "\n Выбрано примитивов: " (itoa int:allEntities)
		     ", из них линейных: " (itoa int:curveEntities)
		     "\n Общая длина линейных примитивов: " (rtos rea:length)
		     )
	     )
    ) ;_  progn
    (alert "Примитивы не выбраны!")
  ) ;_  if
(prin1)
) ;_  defun

Пробуйте...

[Геннадий aka PG]

Сообщение от kos Ну, вот отпуск и кончился...

Правильно, хватит отдыхать, за работу, за работу...

[Vova]

Command: _appload GeneralLength.lsp successfully loaded.

Command: ; error: bad argument type: numberp: nil

[kos]

Сообщение от Vova Command: _appload GeneralLength.lsp successfully loaded. Command: ; error: bad argument type: numberp: nil

Да-а-а?
Бум смотреть.
А в каком Автогаде? Писал под 2004.

[kos]

Я только одного не пойму. В первом сообщении пишет, что лисп загрузился успешно. Это понятно. А где запуск функции? Что, вот так сразу сообщение об ошибке?
Может впереди еще

Код:

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

(vl-load-com)

добавить?

[kos]

Сообщение от Vova Command: _appload GeneralLength.lsp successfully loaded. Command: ; error: bad argument type: numberp: nil

Vova, так я не понял: работает все-таки или нет?

[Vova]

На домашнем 2005 вариант от 20 сент. работает, на работе на 2004 нет. Попробую перенести из дома. Возможно, у меня некорректно выполнилось CTRL+C/V. Там русского яз. нет, но должно было работать с вопросительными знаками вместо комментариев на русском или с моим переводом. (все знаки при переводе я оставлял как было, предыдущая версия работала) Хорошо, что умеет считать в любых единицах. Результат доложу

[Vova]

Все работает отлично, и на работе и дома. Спасибо KOS

[kos]

Сообщение от Vova Все работает отлично, и на работе и дома. Спасибо KOS

Дык, нема за што. Обещал ведь...

;******************************************************************************
;
; Lsum -функция определяет суммарные длинну и площадь набора линий и полилиний
;
;******************************************************************************
(defun C:lsum (/ cmdold nabor nl i j prima sum_line sum_pline asum_pline pt_list)
(vl-load-com)
(setq cmdold (getvar "cmdecho"))
(setvar "cmdecho" 0)
(princ "\n Выберите линии и 2D-полилинии:\n")
(if (eq nil (setq nabor (ssget '((-4 . "<OR")
(0 . "line")
(0 . "lwpolyline")
(-4 . "OR>")
) ) ) )
(progn
(princ "***** Среди указаных объектов ни линий, ни 2D-полилиний НЕТ! *****\n")(textscr)(princ)
)
(progn
(setq nl (sslength nabor))
(setq i nl j 0 sum_line 0 sum_pline 0 asum_pline 0)
(while (< 0 i)
(setq i (1- i))
(setq prima (ssname nabor i))
(if (eq "LWPOLYLINE" (cdr (assoc 0 (entget prima))))
(progn
(command "_AREA" "_o" (ssname nabor i))
(setq sum_pline (+ sum_pline (getvar "Perimeter")))
(if (or (eq 1 (cdr (assoc 70 (entget prima))))
(equal (assoc 10 (entget prima)) (assoc 10 (reverse (entget prima))))
)
(setq asum_pline (+ asum_pline (getvar "Area")))
)
)
(progn
(setq sum_line (+ sum_line (vla-get-length (vlax-ename->vla-object prima))))
(setq pt_list (append pt_list (cdr (assoc 10 (entget prima))) (cdr (assoc 11 (entget prima)))))
(setq j (1+ j))
)
)
)
(setvar "cmdecho" cmdold)
(textscr)
(princ " Выбрано: Линий - ")(princ j)(princ "; Полилиний - ")(princ (- nl j))(princ ".\n")
(princ " Сумма длин линий - ")(princ sum_line)(princ "\n")
(princ " Суммарный периметр полилиний - ")(princ sum_pline)(princ "\n")
(princ " Сумма площадей \"замкнутых\" полилиний - ")(princ asum_pline)(princ "\n")
(princ)
)
)
)




(princ "\n Загружена утилита Lsum,\n")
(princ " вычисляющая сумму длин линий и суммарный периметр полилиний,\n")
(princ " для \"замкнутых\" полилиний вычисляется сумма площадей.\n")
(princ " Для работы с утилитой введите в командной строке Lsum.\n")
(textscr)
(princ)

[Alaspher]

2 kos
Для книги "САПР на базе AutoCAD. Как это делается" был написан набор функций для подсчёта периметра примитивов. Ссылка на головную библиотечную функцию: http://www.kurganobl.ru/cad/book.jsp...=793&tn=main#b
Это библиотечные функции - для создания программы, головная, естественно, должна быть "обёрнута" интерфейсной.

[kos]

Alaspher, а почему http://www.kurganobl.ru/cad/book.jsp...=793&tn=main#b адресуется только мне? Остальным тоже должно быть интересно...

[Alaspher]

Сообщение от kos Alaspher, а почему http://www.kurganobl.ru/cad/book.jsp...=793&tn=main#b адресуется только мне? Остальным тоже должно быть интересно...

Как автору похожего по типу кода (для сравнительного анализа).
А по ссылке, естественно, может сходить каждый, кому это интересно, она-ж не запаролена. Т.е., это не: "2 kos only" :-)

[kos]

Alaspher, спасибо. Кстати, не далее как в пятницу принесли указанную Вами книгу. Курим...

По наводке Fantomasa

Сдесь http://www.resourcecad.com в разделе Downloads. Только надо зарегистрироваться.

набрел на лиспик SUMMIT, который меряет даже длину сплайна.

[kos]

Сообщение от Anonymous По наводке Fantomasa Сдесь http://www.resourcecad.com в разделе Downloads. Только надо зарегистрироваться. набрел на лиспик SUMMIT, который меряет даже длину сплайна.

Процитирую сам себя (Вт Авг 10, 2004 12:02) :

...обсчитываются только примитивы, подпадающие под определение "курва" (curve). Т.е. линейные примимтивы. Блок к ним не относится.

А сплайн - линейный примитив и моей функцией также обсчитывается...

[proekt]

Зачем изобретать велосипед. Есть програмулька vetcad, там есть куча примочек для подсчетов.

[Vova]

Proekt> Автокад это сплошной велодром, здесь много есть такого, что можно изобрести. LISP от KOS для подсчета суммарной длины отрезков, полилиний, дуг, сплайнов, окружностей и многоугольников, то есть всего линейного, очень хорош. Если грамотно расположить те элементы, что надо будет измерить, по слоям, или выбрать их Qselect, то эта программа моментально все просуммирует и сообщит, сколько объектов она обработала и сколько из них обсчитала, отбраковав нелинейные.

[Новичок]

;****************************************************************************** ; ; Lsum -функция определяет суммарные длинну и площадь набора линий и полилиний ; ;****************************************************************************** (defun C:lsum (/ cmdold nabor nl i j prima sum_line sum_pline asum_pline pt_list) (vl-load-com) (setq cmdold (getvar "cmdecho")) (setvar "cmdecho" 0) (princ "\n Выберите линии и 2D-полилинии:\n") (if (eq nil (setq nabor (ssget '((-4 . "<OR") (0 . "line") (0 . "lwpolyline") (-4 . "OR>") ) ) ) ) (progn (princ "***** Среди указаных объектов ни линий, ни 2D-полилиний НЕТ! *****\n")(textscr)(princ) ) (progn (setq nl (sslength nabor)) (setq i nl j 0 sum_line 0 sum_pline 0 asum_pline 0) (while (< 0 i) (setq i (1- i)) (setq prima (ssname nabor i)) (if (eq "LWPOLYLINE" (cdr (assoc 0 (entget prima)))) (progn (command "_AREA" "_o" (ssname nabor i)) (setq sum_pline (+ sum_pline (getvar "Perimeter"))) (if (or (eq 1 (cdr (assoc 70 (entget prima)))) (equal (assoc 10 (entget prima)) (assoc 10 (reverse (entget prima)))) ) (setq asum_pline (+ asum_pline (getvar "Area"))) ) ) (progn (setq sum_line (+ sum_line (vla-get-length (vlax-ename->vla-object prima)))) (setq pt_list (append pt_list (cdr (assoc 10 (entget prima))) (cdr (assoc 11 (entget prima))))) (setq j (1+ j)) ) ) ) (setvar "cmdecho" cmdold) (textscr) (princ " Выбрано: Линий - ")(princ j)(princ "; Полилиний - ")(princ (- nl j))(princ ".\n") (princ " Сумма длин линий - ")(princ sum_line)(princ "\n") (princ " Суммарный периметр полилиний - ")(princ sum_pline)(princ "\n") (princ " Сумма площадей \"замкнутых\" полилиний - ")(princ asum_pline)(princ "\n") (princ) ) ) ) (princ "\n Загружена утилита Lsum,\n") (princ " вычисляющая сумму длин линий и суммарный периметр полилиний,\n") (princ " для \"замкнутых\" полилиний вычисляется сумма площадей.\n") (princ " Для работы с утилитой введите в командной строке Lsum.\n") (textscr) (princ)

А к в этом Lisp добавить чтоб выводилась длина каждого отрезка
Подскажите пожалуйста!

[vk]

Скорей всего что то вроде

Код:

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

........
(progn 
(setq l_line (vla-get-length (vlax-ename->vla-object prima)))
(princ "\nОтрезок ")
(princ l_line)
(setq sum_line (+ sum_line l_line))
(setq pt_list (append pt_list (cdr (assoc 10 (entget prima))) (cdr (assoc 11 (entget prima))))) 
(setq j (1+ j)) 
) 
.......

не проверял....

[Новичок]

Cпасибо большое!!!!!!
немного подправил и заработало

[Apelsinov]

Написал вот такое по совету Alaspher'а (и книжка хорошая).
Считает все что только можно.
есть грабли?

Код:

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

;;;******************************
;;;Apelsinov
;;;apelsinov@pochta.ru
;;;04.02.05
;;;******************************
;;;Длины выбранных примитивов
;;;Функции:
;;;apel-ssget
;;;ru-geom-get-perimeter
;;;ru-ssentget-by-type
(defun c:apel_perim (/ nab str)
  (if (setq nabor (apel-ssget "Выберите примитивы для определения суммарной длины")
      )
    (progn
      (setq
        str (strcat
              "\nСуммарная длина:"
              (rtos
                (apply '+
                       (vl-remove nil
                                  (setq nab (mapcar 'ru-geom-get-perimeter (ru-ss-to-ent-list nabor)))
                       )
                )
              )
;;;Если необходима длина каждого примитива
;;;              (apply 'strcat
;;;                     (cons "\nДлина каждого примитива:"
;;;                           (mapcar '(lambda (i) (strcat "\n" (rtos i)))
;;;                                   (vl-remove nil nab)
;;;                           )
;;;                     )
;;;              )
            )
      )
      (if (vl-member-if 'null nab)
        (setq str (strcat str
                          " \nНе учтенных примитивов из выбранных:"
                          (rtos (length (vl-remove-if-not 'null nab)))
                  )
        )
      )
    )
    (setq str "\nПримитивы не были выбраны")
  )
  (princ str)
  (princ)
)

;;;******************************
;;;Apelsinov
;;;apelsinov@pochta.ru
;;;04.02.05
;;;******************************
;;;SSget с запросом
(defun apel-ssget (str / *error*)
;;; (apel-ssget "Выбери примитивы") -> Command: Выбери примитивы <Выход>:
;;; -> <Selection set: bc> [набор]
  (defun *error* (msg /)
    (setvar "nomutt" 0)
    (princ (strcat "apel-ssget Local-Error:" msg))
  )
  (princ (strcat "\n" str " <Выход>:"))
  (if (eq 0 (getvar "nomutt"))
    (progn (setvar "nomutt" 1)
           (setq nab (ssget))
           (setvar "nomutt" 0)
           (eval nab)
    )
    (ssget)
  )
)

;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Длина периметра примитива или VLA-объекта
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *Сергей Зуев   (ShaggyDoc)
;;; *Пётр Лоскутов (Alaspher)
;;; *Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-geom-get-perimeter (ent / name)
;;;* Аргумент: Ename или VLA-Object
;;;* Если может, возвращает длинну периметра примитива, иначе - NIL.
  (if (= (type ent) 'ename)
    (setq ent (vlax-ename->vla-object ent))
  ) ;_ end of if
  (cond
    ((vlax-property-available-p ent 'length)
     (vla-get-length ent)
    )
    ((vlax-property-available-p ent 'arclength)
     (vla-get-arclength ent)
    )
    ((vlax-property-available-p ent 'circumference)
     (vla-get-circumference ent)
    )
    ((vlax-property-available-p ent 'perimeter)
     (vla-get-perimeter ent)
    )
    ((vl-position
       (setq name (vla-get-objectname ent))
       '("AcDbPolyline" "AcDb3dPolyline" "AcDbEllipse" "AcDbSpline")
     ) ;_ end of vl-position
     (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
    )
    ((vl-position name '("AcDbFace" "AcDbSolid" "AcDbTrace"))
     (ru-3dface-get-perimeter ent)
    )
    ((= name "AcDbMline") (ru-mline-get-length ent))
    ((= name "AcDbViewport") (ru-viewport-get-perimeter ent))
    (t nil)
  ) ;_ end of cond
) ;_ end of defun

;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Длина периметра трехмерной грани
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *		Сергей Зуев   (ShaggyDoc)
;;; *		Пётр Лоскутов (Alaspher)
;;; *		Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-3dface-get-perimeter (face / verts)
;;;* Аргумент: 3DFace, Trace или 2DSolid, Ename или VLA-Object
;;;* Возвращает длинну периметра примитива.
  (if (= (type face) 'vla-object)
    (setq face (vlax-vla-object->ename face))
  ) ;_ end of if
  (setq face  (entget face)
        verts (mapcar 'cdr (ru-ent-dxf-code-clear-list face '(10 11 12 13) t))
  ) ;_ end of setq
  (apply '+ (mapcar 'distance verts (cons (last verts) verts)))
) ;_ end of defun


;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Очистка заданных DXF-кодов в списке
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *		Сергей Зуев   (ShaggyDoc)
;;; *		Пётр Лоскутов (Alaspher)
;;; *		Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-ent-dxf-code-clear-list (lst list_dxf_codes is_stay_value)
  (cond
    ((null lst) NIL)
    ((/= is_stay_value (= (type (member (caar lst) list_dxf_codes)) 'list))
     (ru-ent-dxf-code-clear-list (cdr lst) list_dxf_codes is_stay_value)
    )
    (t
     (cons (car lst)
           (ru-ent-dxf-code-clear-list (cdr lst) list_dxf_codes is_stay_value)
     )
    )
  ) ;_ end of cond
)

;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Длина осевой линии мультилинии
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *		Сергей Зуев   (ShaggyDoc)
;;; *		Пётр Лоскутов (Alaspher)
;;; *		Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-mline-get-length (mline / verts)
;;;* Аргумент: мультилиния, Ename или VLA-Object
;;;* Возвращает длинну осевой мультилинии.
  (if (= (type mline) 'vla-object)
    (setq mline (vlax-vla-object->ename mline))
  ) ;_ end of if
  (setq mline (entget mline)
        verts (mapcar 'cdr
                      (vl-remove-if-not (function (lambda (x) (= (car x) 11))) mline)
              ) ;_ end of mapcar
  ) ;_ end of setq
  (if (not (zerop (logand 2 (cdr (assoc 71 mline)))))
    (setq verts (cons (last verts) verts))
  ) ;_ end of if
  (apply '+ (mapcar 'distance (cdr verts) verts))
) ;_ end of defun

;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Периметр видового экрана
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *		Сергей Зуев   (ShaggyDoc)
;;; *		Пётр Лоскутов (Alaspher)
;;; *		Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-viewport-get-perimeter (vp / clip)
;;;* Аргумент: Viewport, Ename или VLA-Object
;;;* Возвращает длинну периметра Viewport'а, в том числе clipped.
  (if (= (type vp) 'vla-object)
    (setq vp (vlax-vla-object->ename vp))
  ) ;_ end of if
  (setq vp (entget vp))
  (if (setq clip (cdr (assoc 340 vp)))
    (ru-geom-get-perimeter clip)
    (* 2 (+ (cdr (assoc 40 vp)) (cdr (assoc 41 vp))))
  ) ;_ end of if
) ;_ end of defun

;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Конвертирование набора в список примитивов
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *		Сергей Зуев   (ShaggyDoc)
;;; *		Пётр Лоскутов (Alaspher)
;;; *		Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-ss-to-ent-list (selection)
  ;; (ru-ss-to-ent-list (ru-ss-get))
  (if selection
    (vl-remove-if-not
      (function (lambda (x) (= (type x) 'ename)))
      (mapcar 'cadr (ssnamex selection))
    ) ;_ end of vl-remove-if-not
  ) ;_ end of if
) ;_ end of defun

[kos]

В свои коды функций на 1-ой и 2-ой страницах вставил

Код:

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

(vl-load-com)

В связи с тем, что периодически возникают вопросы...

[boker]

Скажите плиз, что надо вводить чтоб заработал последний лисп тот что Apelsinov написал
что надо вводить в командную строку?

[Torino]

apel_perim

[boker]

спасибо, получилось

[{Smirnoff}]

Ну что еще попробуем? Все что было до этого к сожалениию не позволяло предварительно выбрать нужные примитивы с помощью QSelect, Filter, (ssx) да и просто выбрать примитивы а потом уже запустить лисп.

Код:

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

(defun c:elen(/ fList firSet entSet filOut entList totLen)
  (vl-load-com)
  (setq fList '((-4 . "<OR")(0 . "*LINE")
		(0 . "CIRCLE")(0 . "ARC")
		(0 . "ELLIPSE")(-4 . "OR>")
		(-4 . "<NOT")(0 . "MLINE")
		(-4 . "NOT>"))
	filOut 0
	); end setq
  (if
    (not
      (and
	(setq firSet(ssget "_I")
	      entSet(ssget "_I" fList)
	      ); end setq
	); end and
      ); end not
    (setq entSet(ssget fList))
    (setq filOut(-(sslength firSet)(sslength entset)))
    ); end if
  (if entSet
    (progn
      (setq entList
	   (mapcar 'vlax-ename->vla-object 
                    (vl-remove-if 'listp 
                     (mapcar 'cadr(ssnamex entSet))))
	    totLen
	     (apply '+
		    (mapcar '(lambda (x)
			       (vlax-curve-getDistAtParam x
				 (vlax-curve-getEndParam x)))
			    entList); end mapcar
		    ); end apply
	    ); end setq
      (if(/= 0 filOut)
	(princ(strcat "\n" (itoa filout)
		      " were filtered out (unsupported type)"))
	); end if
      (princ(strcat "\nTotal entities: "(itoa(length entList))
		    " Total length: "(rtos totLen)); end strcat
	    ); end princ
      ); end progn
    (progn
        (if(/= 0 filOut)
	(princ(strcat "\n" (itoa filout)
		      " were filtered out (unsupported type)"))
	(princ "\nNothing selected")
	); end if
    ); end progn
    ); end if
      (princ)
      ); end c:elen

Наш штатный психоаналитик не зря закрепил эту тему. Кто следующий :?: 8)

[MIP]

>>Fantomas
А мы поступили следующим образом, навесили на кнопку макрос

Код:

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

^C^C(if (null C:MIP_MIPEntLen)(mi_load "mip_all"));MIPEntLen;

и все работает как часики даже с предварительным выбором и фильтрами! Замечу только что имена команды и файла содержащего Лисп, нужно заменить на заложенные у Вас!

[Apelsinov]

>Fantomas
На вскидку - для мультилинии c:elen выдаст ошибку ....

[{Smirnoff}]

>Apelsinov
Спасибо исправил! Совсем забыл про мультилинию. С мультилинией вопрос сложный... Что мерять? Сумму длинн составляющих её линий или осевую линию как у тебя или самую длинную линию :?: Пока я её не включаю поскольку специалисты в разных областях могут получать некорректные результакты.

[Apelsinov]

Сообщение от Fantomas Ну что еще попробуем? <...>

Еще вариант...
Для не посвященных: от предыдущего моего отличается присутствием предварительного выбора и, наверное, скоростью....может быть
А чем отличается от Фантомасовского непосвященным знать не судьба, разьве что среднюю линию для мульти считает, и еще хрень всякую...

Код:

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

;;;******************************
;;;Apelsinov
;;;apelsinov@pochta.ru
;;;04.05.05
;;;******************************
;;;Длины выбранных примитивов
;;;Функции:
;;;ru-geom-get-perimeter
;;;ru-ssentget-by-type
(defun c:apel_perim (/ str list_len list_len_perim)
  (vl-load-com)
  (if (cond ((ssget "I") T)
	    ((ssget))
      )
    (progn
      (setq list_len_perim
	     (vl-remove
	       nil
	       (vlax-for item
			      (vla-get-ActiveSelectionSet
				(vla-get-ActiveDocument
				  (vlax-get-acad-object)
				)
			      )

		 (setq
		   list_len
		    (cons (ru-geom-get-perimeter item)
			  list_len
		    )
		 )
	       )
	     )
      )
      (setq
	str
	 (strcat
	   "\n Total length for "
	   (rtos (length list_len_perim))
	   " entities:"
	   (rtos (apply
		   '+
		   list_len_perim
		 )
	   )
	 )
      )
      (if (vl-member-if 'null list_len)
	(setq str
	       (strcat str
		       "\n "
		       (rtos (length (vl-remove-if-not 'null list_len)))
		       " were filtered out (unsupported type)"
	       )
	)
      )
    )
    (setq str "\n Nothing selected")
  )
  (princ str)
  (princ)
)


;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Длина периметра примитива или VLA-объекта
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *Сергей Зуев   (ShaggyDoc)
;;; *Пётр Лоскутов (Alaspher)
;;; *Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-geom-get-perimeter (ent / name)
;;;* Аргумент: Ename или VLA-Object
;;;* Если может, возвращает длинну периметра примитива, иначе - NIL.
  (if (= (type ent) 'ename)
    (setq ent (vlax-ename->vla-object ent))
  ) ;_ end of if
  (cond
    ((vlax-property-available-p ent 'length)
     (vla-get-length ent)
    )
    ((vlax-property-available-p ent 'arclength)
     (vla-get-arclength ent)
    )
    ((vlax-property-available-p ent 'circumference)
     (vla-get-circumference ent)
    )
    ((vlax-property-available-p ent 'perimeter)
     (vla-get-perimeter ent)
    )
    ((vl-position
       (setq name (vla-get-objectname ent))
       '("AcDbPolyline" "AcDb3dPolyline" "AcDbEllipse" "AcDbSpline")
     ) ;_ end of vl-position
     (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
    )
    ((vl-position name '("AcDbFace" "AcDbSolid" "AcDbTrace"))
     (ru-3dface-get-perimeter ent)
    )
    ((= name "AcDbMline") (ru-mline-get-length ent))
    ((= name "AcDbViewport") (ru-viewport-get-perimeter ent))
    (t nil)
  ) ;_ end of cond
) ;_ end of defun

;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Длина периметра трехмерной грани
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *		Сергей Зуев   (ShaggyDoc)
;;; *		Пётр Лоскутов (Alaspher)
;;; *		Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-3dface-get-perimeter (face / verts)
;;;* Аргумент: 3DFace, Trace или 2DSolid, Ename или VLA-Object
;;;* Возвращает длинну периметра примитива.
  (if (= (type face) 'vla-object)
    (setq face (vlax-vla-object->ename face))
  ) ;_ end of if
  (setq	face  (entget face)
	verts (mapcar 'cdr
		      (ru-ent-dxf-code-clear-list face '(10 11 12 13) t)
	      )
  ) ;_ end of setq
  (apply '+
	 (mapcar 'distance verts (cons (last verts) verts))
  )
) ;_ end of defun


;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Очистка заданных DXF-кодов в списке
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *		Сергей Зуев   (ShaggyDoc)
;;; *		Пётр Лоскутов (Alaspher)
;;; *		Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-ent-dxf-code-clear-list (lst list_dxf_codes is_stay_value)
  (cond
    ((null lst) NIL)
    ((/= is_stay_value
	 (= (type (member (caar lst) list_dxf_codes)) 'list)
     )
     (ru-ent-dxf-code-clear-list
       (cdr lst)
       list_dxf_codes
       is_stay_value
     )
    )
    (t
     (cons (car lst)
	   (ru-ent-dxf-code-clear-list
	     (cdr lst)
	     list_dxf_codes
	     is_stay_value
	   )
     )
    )
  ) ;_ end of cond
)

;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Длина осевой линии мультилинии
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *		Сергей Зуев   (ShaggyDoc)
;;; *		Пётр Лоскутов (Alaspher)
;;; *		Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-mline-get-length (mline / verts)
;;;* Аргумент: мультилиния, Ename или VLA-Object
;;;* Возвращает длинну осевой мультилинии.
  (if (= (type mline) 'vla-object)
    (setq mline (vlax-vla-object->ename mline))
  ) ;_ end of if
  (setq	mline (entget mline)
	verts (mapcar 'cdr
		      (vl-remove-if-not
			(function (lambda (x) (= (car x) 11)))
			mline
		      )
	      ) ;_ end of mapcar
  ) ;_ end of setq
  (if (not (zerop (logand 2 (cdr (assoc 71 mline)))))
    (setq verts (cons (last verts) verts))
  ) ;_ end of if
  (apply '+ (mapcar 'distance (cdr verts) verts))
) ;_ end of defun

;;; ************************************************************************
;;; * Компонент Интегрированной системы ruCAD
;;; *
;;; * Периметр видового экрана
;;; *
;;; * Copyright ©2004 ruCAD Group
;;; *		Сергей Зуев   (ShaggyDoc)
;;; *		Пётр Лоскутов (Alaspher)
;;; *		Николай Полещук
;;; * http://www.kurganobl.ru/cad
;;; * РАЗРЕШАЕТСЯ ИСПОЛЬЗОВАНИЕ В КОММЕРЧЕСКИХ ПРОГРАММНЫХ ПРОДУКТАХ
;;; * ТОЛЬКО ПРИ ПОСТАВКЕ ЧАСТЕЙ ПРОДУКТА, ИСПОЛЬЗУЮЩИХ НАСТОЯЩИЙ КОМПОНЕНТ,
;;; * С ИСХОДНЫМИ ТЕКСТАМИ
;;; *
;;; ************************************************************************
(defun ru-viewport-get-perimeter (vp / clip)
;;;* Аргумент: Viewport, Ename или VLA-Object
;;;* Возвращает длинну периметра Viewport'а, в том числе clipped.
  (if (= (type vp) 'vla-object)
    (setq vp (vlax-vla-object->ename vp))
  ) ;_ end of if
  (setq vp (entget vp))
  (if (setq clip (cdr (assoc 340 vp)))
    (ru-geom-get-perimeter clip)
    (* 2 (+ (cdr (assoc 40 vp)) (cdr (assoc 41 vp))))
  ) ;_ end of if
) ;_ end of defun

[{Smirnoff}]

По поручению kos. Его вариант лиспа с предварительным выбором:

Код:

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

(vl-load-com)
(defun entLen (/ set:entities      int:allEntities
            int:curveEntities int:l         rea:length
         )
  (if (not (setq set:entities (cadr (ssgetfirst))))    ; Этот if добавлен для
    (setq set:entities (ssget))            ; обработки предварительного
  ) ;_ if                  ; выбора примитивов
  (if set:entities
    (progn
      (setq int:allEntities
        (sslength set:entities)   ; количество выбранных примитивов
       int:curveEntities
        0            ; счетчик линейных примитивов
       int:l 0         ; счетчик
       rea:length
        0.0         ; общая длина линейных примитивов
      ) ;_  setq
      (while (< int:l (sslength set:entities))
   (if
     (not
       (vl-catch-all-error-p
         (vl-catch-all-apply
      'vlax-curve-getStartPoint
      (list
        (vlax-ename->vla-object (ssname set:entities int:l))
      ) ;_ list
         ) ;_  vl-catch-all-apply
       ) ;_  vl-catch-all-error-p
     ) ;_  not
      (setq int:curveEntities (1+ int:curveEntities)
       rea:length      (+ rea:length
                  (vlax-curve-getDistAtParam
               (vlax-ename->vla-object
                 (ssname set:entities int:l)
               ) ;_ vlax-ename->vla-object
               (vlax-curve-getEndParam
                 (ssname set:entities int:l)
               ) ;_ vlax-curve-getEndParam
                  ) ;_  vlax-curve-getDistAtParam
               ) ;_  +
      ) ;_  setq
   ) ;_  if
   (setq int:l (1+ int:l))
      ) ;_  while
      (princ (strcat "\n Выбрано примитивов: "
           (itoa int:allEntities)
           ", из них линейных: "
           (itoa int:curveEntities)
           "\n Общая длина линейных примитивов: "
           (rtos rea:length)
        ) ;_ strcat
      ) ;_ princ
    ) ;_  progn
    (alert "Примитивы не выбраны!")
  ) ;_  if
  (prin1)
) ;_  defun

Кто следующий :?:

[Georg]

Я нашел в форуме Лисп считающий сумму площадей, а мне нужен список площадей объектов в порядке их выбора :?

Apelsinov сделал удобную вещицу для списка длин линий

Код:

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

;;;Если необходима длина каждого примитива 
;;;              (apply 'strcat 
;;;                     (cons "\nДлина каждого примитива:" 
;;;                           (mapcar '(lambda (i) (strcat "\n" (rtos i))) 
;;;                                   (vl-remove nil nab) 
;;;                           ) 
;;;                     ) 
;;;              ) 
            )

пользуюсь, очень удобно
весь лисп на второй странице этой темы

можно прицепить такой же вагончик к подсчету площадей?

[{Smirnoff}]

>Georg

Глянь, может приблизително подойдет http://dwg.ru/forum/viewtopic.php?t=3312 . Эта прога выводит отдельные площади, правда еще плюс габариты и "габаритные" площади. Габаритные прамоугольники и надписи можно и не чертить (опция), а если они начерчены то удаляются одной командой.

[Styx]

Сообщение от Apelsinov Сообщение от Fantomas Ну что еще попробуем? <...> Еще вариант... Для не посвященных: от предыдущего моего отличается присутствием предварительного выбора и, наверное, скоростью....может быть А чем отличается от Фантомасовского непосвященным знать не судьба, разьве что среднюю линию для мульти считает, и еще хрень всякую...

При выборе мультилинии в ACAD2006 выдает:
Select objects:
; error: no function definition: RU-GEOM-GET-PERIMETER

:?: :?:

[Karales]

Ищу LISP (и.т.п) для измерения длин труб(цилиндров) разных диаметров.

[you_you]

Работаю в ACAD 2007
Сохранил тект от kos`а со второй странице этой темы, подгрузил, но:
Command: _appload entLen.lsp successfully loaded.
Command:
Command:
Command: entLen
Unknown command "ENTLEN". Press F1 for help.

методом научного тыка определил, что выполняется только один лисп :

Код:

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

(defun C:Dlina (/ Nab Sum i Curve Param)
(vl-load-com)
(if (setq Nab (ssget))
(progn
(setq Sum 0 i 0)
(repeat (sslength Nab)
(setq Curve (vlax-ename->vla-object (ssname Nab i))

i (1+ i)
Param (vl-catch-all-apply 'vlax-curve-getEndParam
(list Curve))
)
(if (not (vl-catch-all-error-p Param))
(setq Sum (+ Sum (vlax-curve-getDistAtParam Curve
Param)))
)
)
)
)
(princ (strcat "\nСумма длин выбранных элементов равна: " (rtos Sum 2 2)))
(prin1)
)

Где искать причину?

[Мечтатель]

Простенько считает длину линий и выдает результат в командной строке, вдруг подойдет, (не хочу показаться навязчивым грузим ap... команда summline)

(defun C:summline ( / mnv l i td p1 p2)
(setq mnv (ssget) i 0 td 0)
(setq l (if (null mnv) 0 (sslength mnv)))
(repeat l
(setq sp (entget (ssname mnv i)) i (1+ i))
(if (= (cdr (assoc 0 sp)) "LINE" ) (progn
(setq p1 (cdr (assoc 10 sp)) p2 (cdr (assoc 11 sp)))
(setq td (+ (distance p1 p2) td))
))
)
(princ "\nL=") (princ td)
(prin1)
)

[Мечтатель]

чет не доглядел страницы до конца, постыдился бы выкладывать

[Кулик Алексей aka kpblc]

> you_you: лисп kos'a вызывать как (entlen), то есть со скобками. Если хочешь вызывать без скобок, замени строку

Код:

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

(defun entLen ( / set:entities int:allEntities int:curveEntities int:l rea:length)

на

Код:

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

(defun c:entLen ( / set:entities int:allEntities int:curveEntities int:l rea:length)

После этого вызов с ком.строки будет как entlen.

[you_you]

> Кулик Алексей aka kpblc
Спасибо, помогло.

[novichok7]

Сообщение от {Smirnoff} По поручению kos. Его вариант лиспа с предварительным выбором:

Здравствуйте!
А как дописать код, чтобы итоговая сумма не только выводилась на экран, но и кидалась в буфер обмена. Спасибо.

[VVA]

>novichok7
Отредактированный вариант

Код:

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

(vl-load-com)
(if (null *MIP-MODEMACRO-HTXT*)(setq *MIP-MODEMACRO-HTXT* 3.0)) ;_Высота текста
(if (null *MIP-MODEMACRO-RTOS*)(setq *MIP-MODEMACRO-RTOS* -1.0));_Округление -1-LUPREC
(if (null *MIP-MODEMACRO-SCALE*)(setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштаб
(VL-PROPAGATE '*MIP-MODEMACRO-HTXT*)
(VL-PROPAGATE '*MIP-MODEMACRO-RTOS*)
(VL-PROPAGATE '*MIP-MODEMACRO-SCALE*)
(defun C:entLen (/ set:entities      int:allEntities 
            int:curveEntities int:l         rea:length 
         )
  (princ "\nТекущий коэффициент K=")(princ (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst))))    ; Этот if добавлен для 
    (setq set:entities (ssget))            ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities 
    (progn 
      (setq int:allEntities 
        (sslength set:entities)   ; количество выбранных примитивов 
       int:curveEntities 
        0            ; счетчик линейных примитивов 
       int:l 0         ; счетчик 
       rea:length 
        0.0         ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities)) 
   (if 
     (not 
       (vl-catch-all-error-p 
         (vl-catch-all-apply 
      'vlax-curve-getStartPoint 
      (list 
        (vlax-ename->vla-object (ssname set:entities int:l)) 
      ) ;_ list 
         ) ;_  vl-catch-all-apply 
       ) ;_  vl-catch-all-error-p 
     ) ;_  not 
      (setq int:curveEntities (1+ int:curveEntities) 
       rea:length      (+ rea:length 
                  (vlax-curve-getDistAtParam 
               (vlax-ename->vla-object 
                 (ssname set:entities int:l) 
               ) ;_ vlax-ename->vla-object 
               (vlax-curve-getEndParam 
                 (ssname set:entities int:l) 
               ) ;_ vlax-curve-getEndParam 
                  ) ;_  vlax-curve-getDistAtParam 
               ) ;_  + 
      ) ;_  setq 
   ) ;_  if 
   (setq int:l (1+ int:l)) 
      ) ;_  while
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (princ (strcat "\n Выбрано примитивов: " 
           (itoa int:allEntities) 
           ", из них линейных: " 
           (itoa int:curveEntities)
           "\nПоправочный коэфиициент K="                     
           "\n Общая длина линейных примитивов: "
        (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))                     
        ) ;_ strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны!") 
  ) ;_  if 
  (prin1) 
) ;_  defun

(defun c:MM ( / buf )
  (initget 7)
  (setq *MIP-MODEMACRO-SCALE* (getreal "\nНовый масштабный коэффициент: "))
  (initget 6)
  (princ "\nВысота текста <")(princ *MIP-MODEMACRO-HTXT*)(princ ">: ") 
  (if (setq buf (getdist))(setq *MIP-MODEMACRO-HTXT* buf))
  (initget 4 "L")
  (princ "\nТочность округления [Luprec] <")
  (if (< *MIP-MODEMACRO-RTOS* 0)(princ "Luprec")(princ *MIP-MODEMACRO-RTOS*))
  (princ ">: ") 
  (if (setq buf (getint))(setq *MIP-MODEMACRO-RTOS* (if (numberp buf) buf -1)))
  (VL-PROPAGATE '*MIP-MODEMACRO-HTXT*)
  (VL-PROPAGATE '*MIP-MODEMACRO-RTOS*)
  (VL-PROPAGATE '*MIP-MODEMACRO-SCALE*)
  (princ)
  )
(defun c:LP ( )(if (= (type *MIP-LENGTH*) 'REAL)(progn
(vla-addtext(vla-get-block(vla-get-ActiveLayout(vla-get-ActiveDocument(vlax-get-acad-object))))
(rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))  
(vlax-3d-point '(0 0 0)) *MIP-MODEMACRO-HTXT*)(princ "\n Укажите точку вставки текста:")
(command "_.copybase" '(0 0 0) (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause)))
(princ))

Определены 3 команды
EntLEN - суммирует длинны выбранных объектов с учетом поправочного коэффициента
MM - устанавливает параметры:
- поправочный коэфициент
- точность округления
- высоту текста
LP - печатает разультат. Сам результат хранится в глобальной переменной *MIP-LENGTH*. Можно посмотреть, набрав !*MIP-LENGTH* в командной строке

*** Добавлено 28.04.2008
Версия команды LP с разделителем запятой

Код:

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

(defun c:LP ( )(if (= (type *MIP-LENGTH*) 'REAL)(progn
(vla-addtext(vla-get-block(vla-get-ActiveLayout(vla-get-ActiveDocument(vlax-get-acad-object))))
(vl-string-translate "." ","  
(rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))
  )
(vlax-3d-point '(0 0 0)) *MIP-MODEMACRO-HTXT*)(princ "\n Укажите точку вставки текста:")
(command "_.copybase" '(0 0 0) (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause)))
(princ))

*** Добавлено 07.11.2012
Вариант с реакторами

[novichok7]

Спасибо.
Одно только уточнение.
А как мне сделать, чтобы значение из переменной MIP-LENGTH попало в буфер обмена Windows. Суть - я потом в Excel эти значения копирую и считаю. Т.е. сейчас мышью или клавиатурой выделяю полученное значение, потом Ctrl+C, перехожу в Excel, Ctrl+V.

[Krieger]

[quote=novichok7]

Сообщение от "VVA Спасибо. Одно только уточнение. А как мне сделать, чтобы значение из переменной MIP-LENGTH попало в буфер обмена Windows. Суть - я потом в Excel эти значения копирую и считаю. Т.е. сейчас мышью или клавиатурой выделяю полученное значение, потом Ctrl+C, перехожу в Excel, Ctrl+V.

У меня попало
Сделал так:
Качаешь DOSLib вот от сюда:
http://www.en.na.mcneel.com/doslib.htm
Устанавливаешь, и в итоге у тебя появится "c:\Program Files\DOSLib 7.5\DOSLib17.arx"
Этот DOSLib17.arx кидаешь в автозагрузку, а в коде из поста 62, после строчки

Код:

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

(setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))

добавишь эту:

Код:

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

(if dos_clipboard (dos_clipboard (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))))

[novichok7]

Спасибо. Все заработало!!!

[dextron3]

Сообщение от {Smirnoff} Ну что еще попробуем? Все что было до этого к сожалениию не позволяло предварительно выбрать нужные примитивы с помощью QSelect, Filter, (ssx) да и просто выбрать примитивы а потом уже запустить лисп. Код: [Выделить все] (defun c:elen(/ fList firSet entSet filOut entList totLen) (vl-load-com) (setq fList '((-4 . "<OR")(0 . "*LINE") (0 . "CIRCLE")(0 . "ARC") (0 . "ELLIPSE")(-4 . "OR>") (-4 . "<NOT")(0 . "MLINE") (-4 . "NOT>")) filOut 0 ); end setq (if (not (and (setq firSet(ssget "_I") entSet(ssget "_I" fList) ); end setq ); end and ); end not (setq entSet(ssget fList)) (setq filOut(-(sslength firSet)(sslength entset))) ); end if (if entSet (progn (setq entList (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr(ssnamex entSet)))) totLen (apply '+ (mapcar '(lambda (x) (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))) entList); end mapcar ); end apply ); end setq (if(/= 0 filOut) (princ(strcat "\n" (itoa filout) " were filtered out (unsupported type)")) ); end if (princ(strcat "\nTotal entities: "(itoa(length entList)) " Total length: "(rtos totLen)); end strcat ); end princ ); end progn (progn (if(/= 0 filOut) (princ(strcat "\n" (itoa filout) " were filtered out (unsupported type)")) (princ "\nNothing selected") ); end if ); end progn ); end if (princ) ); end c:elen Наш штатный психоаналитик не зря закрепил эту тему. Кто следующий :?: 8)

А нельзя ли сделать чтобы исходный ответ т.е. длина в метрах выводилась не так (1893792), а вот так (1893.792 метрофф) :roll: :idea:

[Zouss]

попробовать

Код:

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

          " Total length: "(rtos totLen)); end strcat

отредактировать следующим образом

Код:

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

          " Total length: "(rtos (/ totLen 1000))); end strcat

[VVA]

>dextron3
Возьми код с поста №62. До ввода команды EntLen, введи MM, укажи масштабный коэффициент 0.001

[dextron3]

Сообщение от Zouss попробовать Код: [Выделить все] " Total length: "(rtos totLen)); end strcat отредактировать следующим образом Код: [Выделить все] " Total length: "(rtos (/ totLen 1000))); end strcat

У тебя округляет до метра если 400мм то пишет 0

[dextron3]

Сообщение от VVA >dextron3 Возьми код с поста №62. До ввода команды EntLen, введи MM, укажи масштабный коэффициент 0.001

Не могу сообразить куда что вставить, можно сделать просто обычную сумарку примтивов без коэфициентов дополнительных

чтобы выдавала если у тебя так 290385,
то выдает так 290.39 метров т.е. округляет до двух знаков после запятой, остальное просто не нужно
пусть будет просто универсальный лисп

а дальше уже каждый будет тюнинговать по своему

VVA спасибо за ЛИСП про массивы :roll: :roll: :roll:

[Кулик Алексей aka kpblc]

либо меняй luprec, либо использовать строку

Код:

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

" Total length: "(rtos (/ totLen 1000) 2 3)); end strcat

Посмотри на опции rtos в справке

[VVA]

>dextron3
Возьми лисп с поста №62. Добавь в начало 2 строчки. И будешь иметь масштаб по умолчанию 0.001 и округление до 2 символов

Код:

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

;_==== Добавляемые строчки НАЧАЛО =======
(setq *MIP-MODEMACRO-RTOS* 2)      ;_Округление до 2-х знаков
(setq *MIP-MODEMACRO-SCALE* 0.001) ;_Масштаб 
;_==== Добавляемые строчки КОНЕЦ =======
(vl-load-com) 
(if (null *MIP-MODEMACRO-HTXT*)(setq *MIP-MODEMACRO-HTXT* 3.0)) ;_Высота текста 
(if (null *MIP-MODEMACRO-RTOS*)(setq *MIP-MODEMACRO-RTOS* -1.0));_Округление -1-LUPREC 
(if (null *MIP-MODEMACRO-SCALE*)(setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштаб

[dextron3]

VVA

1) Спасибо все работет только слово "МЕТРОВ" не пишет


2) Как можно чтобы этот ЛИСП общую длинну делил на 200, количество укруглял до целого в большую сторону, а результат копировал в буфер в виде целого числа

Допустим измерели: 2398472
Результат: 11993 в буфере
ну и естественно в командной строке предварительно выврдился в таком виде 11993 шт.

[dextron3]

если сложно весь лисп перепечатывать скажи какую строчку заменить на какую


заранее благодарен

[VVA]

Отредактированный вариант лиспа из поста №62
Добавлено:
1. Копирование результата в clipboard Windows. Библиотеки Doslib не требуется.
2. При печати "Выбрано примитивов и т.п. ..." не печатался коэффициент
3. Для тех, кто хочет, чтобы печатались единицы измерения нужно найти строчку

Код:

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

"" ;_<< Добавлено 18.06.2007 сюда можно писать единицы, например метры и т.п.

И вместо "" вбить свое (например " метры")
Пример для метров

Код:

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

(princ (strcat "\n Выбрано примитивов: " 
           (itoa int:allEntities) 
           ", из них линейных: " 
           (itoa int:curveEntities) 
           "\nПоправочный коэфиициент K=" (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*)
           "\n Общая длина линейных примитивов: " 
        (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))
        "  метров" ;_<< Добавлено 18.06.2007 сюда можно писать единицы, например метры и т.п.
        ) ;_ strcat 
      )

Код:

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

;  ! ***************************************************************************
;; !                           copyToclipboard
;; ! ***************************************************************************
;; ! Function : Copy text to clipboard
;; ! Argument : 'str'     - String
;; ! Returns  : nil
;; see http://www.theswamp.org/index.php?topic=21764.new
;; ! ****************************************************************************

(defun copyToclipboard ( text / htmlfile result)
 (setq result
        (vlax-invoke
            (vlax-get
                (vlax-get
                    (setq htmlfile (vlax-create-object "htmlfile"))
                   'ParentWindow
                )
               'ClipBoardData
            )
           'SetData
            "Text"
            text
        )
    )

    (vlax-release-object htmlfile)
  result
)
(if (null *MIP-MODEMACRO-HTXT*)(setq *MIP-MODEMACRO-HTXT* 3.0)) ;_Высота текста 
(if (null *MIP-MODEMACRO-RTOS*)(setq *MIP-MODEMACRO-RTOS* -1.0));_Округление -1-LUPREC 
(if (null *MIP-MODEMACRO-SCALE*)(setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштаб 
(VL-PROPAGATE '*MIP-MODEMACRO-HTXT*) 
(VL-PROPAGATE '*MIP-MODEMACRO-RTOS*) 
(VL-PROPAGATE '*MIP-MODEMACRO-SCALE*)
(defun C:entLen (/ set:entities      int:allEntities 
            int:curveEntities int:l         rea:length 
         ) 
  (princ "\nТекущий коэффициент K=")(princ (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst))))    ; Этот if добавлен для 
    (setq set:entities (ssget))            ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities 
    (progn 
      (setq int:allEntities 
        (sslength set:entities)   ; количество выбранных примитивов 
       int:curveEntities 
        0            ; счетчик линейных примитивов 
       int:l 0         ; счетчик 
       rea:length 
        0.0         ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities)) 
   (if 
     (not 
       (vl-catch-all-error-p 
         (vl-catch-all-apply 
      'vlax-curve-getStartPoint 
      (list 
        (vlax-ename->vla-object (ssname set:entities int:l)) 
      ) ;_ list 
         ) ;_  vl-catch-all-apply 
       ) ;_  vl-catch-all-error-p 
     ) ;_  not 
      (setq int:curveEntities (1+ int:curveEntities) 
       rea:length      (+ rea:length 
                  (vlax-curve-getDistAtParam 
               (vlax-ename->vla-object 
                 (ssname set:entities int:l) 
               ) ;_ vlax-ename->vla-object 
               (vlax-curve-getEndParam 
                 (ssname set:entities int:l) 
               ) ;_ vlax-curve-getEndParam 
                  ) ;_  vlax-curve-getDistAtParam 
               ) ;_  + 
      ) ;_  setq 
   ) ;_  if 
   (setq int:l (1+ int:l)) 
      ) ;_  while 
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (copyToclipboard (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)));_<< Добавлено 18.06.2007
      (princ (strcat "\n Выбрано примитивов: " 
           (itoa int:allEntities) 
           ", из них линейных: " 
           (itoa int:curveEntities) 
           "\nПоправочный коэфиициент K=" (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*)
           "\n Общая длина линейных примитивов: " 
        (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))
        "" ;_<< Добавлено 18.06.2007 сюда можно писать единицы, например метры и т.п.
        ) ;_ strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны!") 
  ) ;_  if 
  (princ) 
) ;_  defun 

(defun c:MM ( / buf ) 
  (initget 7) 
  (setq *MIP-MODEMACRO-SCALE* (getreal "\nНовый масштабный коэффициент: ")) 
  (initget 6) 
  (princ "\nВысота текста <")(princ *MIP-MODEMACRO-HTXT*)(princ ">: ") 
  (if (setq buf (getdist))(setq *MIP-MODEMACRO-HTXT* buf)) 
  (initget 4 "L") 
  (princ "\nТочность округления [Luprec] <") 
  (if (< *MIP-MODEMACRO-RTOS* 0)(princ "Luprec")(princ *MIP-MODEMACRO-RTOS*)) 
  (princ ">: ") 
  (if (setq buf (getint))(setq *MIP-MODEMACRO-RTOS* (if (numberp buf) buf -1)))
  (VL-PROPAGATE '*MIP-MODEMACRO-HTXT*) 
  (VL-PROPAGATE '*MIP-MODEMACRO-RTOS*) 
  (VL-PROPAGATE '*MIP-MODEMACRO-SCALE*) 
  (princ) 
  ) 
(defun c:LP ( )(if (= (type *MIP-LENGTH*) 'REAL)(progn 
(vla-addtext(vla-get-block(vla-get-ActiveLayout(vla-get-ActiveDocument(vlax-get-acad-object)))) 
(rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))  
(vlax-3d-point '(0 0 0)) *MIP-MODEMACRO-HTXT*)(princ "\n Укажите точку вставки текста:") 
(command "_.copybase" '(0 0 0) (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause))) 
(princ))

[VVA]

>dextron3
1. см. п.3
В начало по прежнему добавь эти строки

Код:

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

;_==== Добавляемые строчки НАЧАЛО ======= 
(setq *MIP-MODEMACRO-RTOS* 2)      ;_Округление до 2-х знаков 
(setq *MIP-MODEMACRO-SCALE* 0.001) ;_Масштаб 
;_==== Добавляемые строчки КОНЕЦ =======

2.

общую длинну делил на 200

Это то же самое, что умножить на 0.005

Код:

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

(setq *MIP-MODEMACRO-SCALE* 0.005) ;_Масштаб  / 200

Для округления в большую сторону надо вставить строчку
Было

Код:

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

(setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
(copyToclipboard (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)));_<< Добавлено 18.06.2007

Должно стать

Код:

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

(setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
(setq *MIP-LENGTH* (fix (+ *MIP-LENGTH* 0.999))) ;_<<Округление
(copyToclipboard (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)));_<< Добавлено 18.06.2007

[dextron3]

VVA

какойто вирусованный лисп N75, автокад сразу вылетает предварительно минут пять повисев


что то тут не так
[ATTACH]1182170952.JPG[/ATTACH]

[VVA]

>dextron3
Разберись со своим антивирусом или файерволлом.
В автокаде с помощью ActiveX создается копия internet explorera, чтобы с помощью его методов занести данные в clipboard.

Вот 4 сточки. Заносит строку ZZZ в буфер
1. Создаем объект IE

Код:

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

(setq ieobj (vlax-get-or-create-object "InternetExplorer.Application"))

2. Задаем пустую стриницy

Код:

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

(vlax-invoke ieobj 'navigate2 "about:blank")

3. Заносим в clipboard строку ZZZ

Код:

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

(vlax-invoke(vlax-get(vlax-get (vlax-get ieobj 'document) 'parentwindow) 
'clipboarddata) 
'setdata 
"text" 
"ZZZ"
)

4.Удаляем объект IE

Код:

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

(vlax-release-object ieobj)

Выполни их пошагово, на какой вылетает?

[dextron3]

спасибо VVA

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

заранее благодарен

clipboard что то меня не устраивает

и на этом лиспе данная тема будет исчерпана :arrow:

[VVA]

Код:

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

;Опубликовано http://forum.dwg.ru/showthread.php?p=146973#post146973
(vl-load-com) 
(defun C:entLen200 (/ set:entities      int:allEntities 
            int:curveEntities int:l         rea:length
*MIP-MODEMACRO-HTXT* *MIP-MODEMACRO-RTOS* *MIP-MODEMACRO-SCALE*
         )
(setq *MIP-MODEMACRO-HTXT* 3.0) ;_Высота текста 
(setq *MIP-MODEMACRO-RTOS* 0);_Округление -1-LUPREC 
(setq *MIP-MODEMACRO-SCALE* 0.005) ;_Масштаб 1/200 
  
  (princ "\nТекущий коэффициент K=")(princ (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*)) 
  (if (not (setq set:entities (cadr (ssgetfirst))))    ; Этот if добавлен для 
    (setq set:entities (ssget))            ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities 
    (progn 
      (setq int:allEntities 
        (sslength set:entities)   ; количество выбранных примитивов 
       int:curveEntities 
        0            ; счетчик линейных примитивов 
       int:l 0         ; счетчик 
       rea:length 
        0.0         ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities)) 
   (if 
     (not 
       (vl-catch-all-error-p 
         (vl-catch-all-apply 
      'vlax-curve-getStartPoint 
      (list 
        (vlax-ename->vla-object (ssname set:entities int:l)) 
      ) ;_ list 
         ) ;_  vl-catch-all-apply 
       ) ;_  vl-catch-all-error-p 
     ) ;_  not 
      (setq int:curveEntities (1+ int:curveEntities) 
       rea:length      (+ rea:length 
                  (vlax-curve-getDistAtParam 
               (vlax-ename->vla-object 
                 (ssname set:entities int:l) 
               ) ;_ vlax-ename->vla-object 
               (vlax-curve-getEndParam 
                 (ssname set:entities int:l) 
               ) ;_ vlax-curve-getEndParam 
                  ) ;_  vlax-curve-getDistAtParam 
               ) ;_  + 
      ) ;_  setq 
   ) ;_  if 
   (setq int:l (1+ int:l)) 
      ) ;_  while 
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length)) 
      (setq *MIP-LENGTH* (fix (+ *MIP-LENGTH* 0.999))) ;_<<Округление 
      (princ (strcat "\n Выбрано примитивов: " 
           (itoa int:allEntities) 
           ", из них линейных: " 
           (itoa int:curveEntities) 
           "\nПоправочный коэфиициент K=" (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*) 
           "\n Общая длина линейных примитивов: " 
        (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)) 
        " шт." ;_<< Добавлено 18.06.2007 сюда можно писать единицы, например метры и т.п. 
        ) ;_ strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны!") 
  ) ;_  if 
  (princ) 
) ;_  defun

[VVA]

*** Удалено *** Повторение поста № 80

[Джек]

Всем привет!!!
Я вот пользуюсь программой который сделал автор Крыс. Спасибо ему огромное!!!!! 8)

Код:

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

(defun c:mlen2 (/ adoc selset layer_list init _kpblc-string-subst 
item sum_len)
  (vl-load-com)
  (setq  adoc  (vla-get-activedocument (vlax-get-acad-object))
  sum_len  0.0
  ) ;_ end of setq
  (vla-startundomark adoc)
  (if
    (setq ent (entsel "\nУкажите примитив, с которого брать слой 
<Выход> : "))
     (progn
       (setq selset (ssget (list (assoc 8 (entget (car ent))))))
       (while (and selset
       (> (sslength selset) 0)
       ) ;_ end of and
   (setq item (ssname selset 0))
   (ssdel item selset)
   (setq item    (vlax-ename->vla-object item)
         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)
            ) ;_ end of cond
          ) ;_ end of if
        ) ;_ end of +
         ) ;_ end of setq
   ) ;_ end of while
       (setq sum_len_m (/ sum_len 1000.0)) ;; перевод мм в м
       (setq sum_len_m_10% (* 1.1 sum_len_m))
       (alert
	 (strcat "\n Общая длина примитивов " (rtos sum_len 2 2) " мм"
		 "\n или "(rtos sum_len_m 2 2)" м. "
                 "\n С учетом коэфф. запаса " (rtos sum_len_m_10% 2 2)" м."
		 		 ) ; end strcat
	 ); end alert
       ) ;_ end of progn
     ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

Программа хорошая , но есть не большие замечания, не видно (забываешь) с какого слоя выбирается объекты.
Можно переделать программу чтоб она считала отрезки, полилинии , только ВКЛЮЧЕННЫХ слоев и выдавала список.
Например:
Слой 1 – общая длина ХХ
Слой 11 – общая длина ХХХ
Спасибо. Джек.

[VVA]

>Джек Так чего остановился на mlen2? далее есть и mlen3 от Евгения Елпанова.
LISP. Подсчет длины линий на определенном слое

[dextron3]

VVA

протестировал по полной
спасибо лисп работает так, как и хотелось,
:wink: :wink: :wink: :wink: :wink: :wink:

и за лисп с массивами отдельное спасибоспасибо

[Джек]

VVA спасибо за совет!
Но хотелось не много по другому!!!!!!
Хотелось чтоб программа считала отрезки, полилинии , только ВКЛЮЧЕННЫХ слоев и выдавала список.
:roll: Например:
Слой 1 – общая длина ХХ
Слой 11 – общая длина ХХХ
Спасибо. Джек.

[F5623]

А как сделать так, чтобы результаты выводились не только в командной строке, а еще и возле курсора?

[МИНЗДРАВ]

Что делать с этими кодами, что-бы суммарную длинну выделенных линий посчитать?
Нельзя, что-нибудь без программирования для пользователя выложить?

[Кулик Алексей aka kpblc]

Что делать: dwg.ru/art/8
Без программирования: нет. Ну или руками выписывать на бумажку длины и потом складывать.

[Dym]

штучка от Александра Ривилиса
особо хороша в паре этим

[МИНЗДРАВ]

Сообщение от Кулик Алексей aka kpblc dwg.ru/art/8

Прочитал. Применил. Но ни один код не работает!
Что-то пишет там, шевелится. Но заветного числа, я не вижу (ничего похожего в наборе символов там нет).
Подскажите где это самое число видно должно быть?
Может оно где, в специальном укромном файле сохраняется?

[VVA]

Что применил-то? Советую #89

[kubik67]

на сайте выложен хороший калькулятор - calcacad - он суммирует и длину линий, и многое другое. Поищи в даунлоаде, я постоянно им пользуюсь.

[Mikha]

>>МИНЗДРАВ
Посмотри здесь http://dwg.ru/dnl/2733
и здесь http://dwg.ru/dnl/486

[VDeNisV]

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

[VVA]

А ты сходи по ссылке из #83 на последнюю страничку и почитай про mlen4 и mlen41

[VDeNisV]

Спасибо огромное! То что нужно!

[skkkk]

а можно сделать наоборот: имеется линия, откладываем нужный размер от ее начала, и она разрывается в этом месте???

[МИНЗДРАВ]

Сообщение от skkkk имеется линия, откладываем нужный размер от ее начала, и она разрывается в этом месте???

Это легко достигается встроенными средствами AutoCada/

[skkkk]

VVA, подскажите пожалуйста, как поменять в вашем лиспе с поста 62 точку на запятую в результате?

МИНЗДРАВ, А для непрямой полилинии есть возможность обойтись встроенными средствами??Расскажите пожалуйста)

VVA, и еще просьба....подскажите, как записать ответ в готовый текст (оверрайт вроде), предварительно приплюсовав к нему число....Заранее спасибо:-)

[VVA]

skkkk,
1. Добавил код в #62
3. Там такой возможности не предусматривалось. Быстро можно взять код с поста #366 И воспользоваться командой sumTE. Правда настройка разделителя (точка или запятая) будет в новой версии.

А для непрямой полилинии есть возможность обойтись встроенными средствами??Расскажите пожалуйста)

Команда разметь (_measure) откладывает расстояния вдоль оси выбранного примитива. Это может быть и "кривая" полилиния или не менее "кривой" сплайн

[skkkk]

VVA, дай Бог Вам здоровья!!

[skkkk]

Сообщение от VVA skkkk Там такой возможности не предусматривалось...

и невозможно предусмотреть?

Сообщение от VVA skkkk Команда разметь (_measure) откладывает расстояния вдоль оси выбранного примитива. Это может быть и "кривая" полилиния или не менее "кривой" сплайн

Разметил, долго думал, как разбить потом полилинию в местах разметки точками, пришел к тому, что на эти точки реагирует привязка "узел". А нельзя проще их делить, например взорвать полилинию как-нибудь в местах разметки?

[skkkk]

А можно подправить лисп с # 62 так, чтобы он только записывал результат в готовый текст, без приплюсовки числа?(я изменил вопрос из #99). Для приплюсовки я нашел другой лисп. Уж очень неудобно центрировать этот текст вне таблицы

[VVA]

Команда LP переименована в LPN (Length Print to New text)
Добавлена команда LPE (Length Print to Existing text)
В качестве "приемника" подсчитанной длины может выступать текст, мтекст, размер, ячейка таблицы, атрибут блока

Код:

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

(vl-load-com)
(if (null *MIP-MODEMACRO-HTXT*)(setq *MIP-MODEMACRO-HTXT* 3.0)) ;_Высота текста
(if (null *MIP-MODEMACRO-RTOS*)(setq *MIP-MODEMACRO-RTOS* -1.0));_Округление -1-LUPREC
(if (null *MIP-MODEMACRO-SCALE*)(setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштаб
(VL-PROPAGATE '*MIP-MODEMACRO-HTXT*)
(VL-PROPAGATE '*MIP-MODEMACRO-RTOS*)
(VL-PROPAGATE '*MIP-MODEMACRO-SCALE*)
(defun C:entLen (/ set:entities      int:allEntities 
            int:curveEntities int:l         rea:length 
         )
  (princ "\nТекущий коэффициент K=")(princ (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst))))    ; Этот if добавлен для 
    (setq set:entities (ssget))            ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities 
    (progn 
      (setq int:allEntities 
        (sslength set:entities)   ; количество выбранных примитивов 
       int:curveEntities 
        0            ; счетчик линейных примитивов 
       int:l 0         ; счетчик 
       rea:length 
        0.0         ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities)) 
   (if 
     (not 
       (vl-catch-all-error-p 
         (vl-catch-all-apply 
      'vlax-curve-getStartPoint 
      (list 
        (vlax-ename->vla-object (ssname set:entities int:l)) 
      ) ;_ list 
         ) ;_  vl-catch-all-apply 
       ) ;_  vl-catch-all-error-p 
     ) ;_  not 
      (setq int:curveEntities (1+ int:curveEntities) 
       rea:length      (+ rea:length 
                  (vlax-curve-getDistAtParam 
               (vlax-ename->vla-object 
                 (ssname set:entities int:l) 
               ) ;_ vlax-ename->vla-object 
               (vlax-curve-getEndParam 
                 (ssname set:entities int:l) 
               ) ;_ vlax-curve-getEndParam 
                  ) ;_  vlax-curve-getDistAtParam 
               ) ;_  + 
      ) ;_  setq 
   ) ;_  if 
   (setq int:l (1+ int:l)) 
      ) ;_  while
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (princ (strcat "\n Выбрано примитивов: " 
           (itoa int:allEntities) 
           ", из них линейных: " 
           (itoa int:curveEntities)
           "\nПоправочный коэфиициент K="                     
           "\n Общая длина линейных примитивов: "
        (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))                     
        ) ;_ strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны!") 
  ) ;_  if 
  (prin1) 
) ;_  defun
(defun c:MM ( / buf )
  (initget 7)
  (setq *MIP-MODEMACRO-SCALE* (getreal "\nНовый масштабный коэффициент: "))
  (initget 6)
  (princ "\nВысота текста <")(princ *MIP-MODEMACRO-HTXT*)(princ ">: ") 
  (if (setq buf (getdist))(setq *MIP-MODEMACRO-HTXT* buf))
  (initget 4 "L")
  (princ "\nТочность округления [Luprec] <")
  (if (< *MIP-MODEMACRO-RTOS* 0)(princ "Luprec")(princ *MIP-MODEMACRO-RTOS*))
  (princ ">: ") 
  (if (setq buf (getint))(setq *MIP-MODEMACRO-RTOS* (if (numberp buf) buf -1)))
  (VL-PROPAGATE '*MIP-MODEMACRO-HTXT*)
  (VL-PROPAGATE '*MIP-MODEMACRO-RTOS*)
  (VL-PROPAGATE '*MIP-MODEMACRO-SCALE*)
  (princ)
  )
(defun TTC_Paste(pasteStr keepText / nslLst vlaObj)
(if (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки <выход>: "))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE
;;Length Print to Existing text
(defun c:LPE ( )
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." ","  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 nil))
(princ))
;;Length Print to New text
(defun c:LPN ( )(if (= (type *MIP-LENGTH*) 'REAL)(progn
(vla-addtext(vla-get-block(vla-get-ActiveLayout(vla-get-ActiveDocument(vlax-get-acad-object))))
(vl-string-translate "." ","  
(rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))
  )
(vlax-3d-point '(0 0 0)) *MIP-MODEMACRO-HTXT*)(princ "\n Укажите точку вставки текста:")
(command "_.copybase" '(0 0 0) (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause)))
(princ))
(princ "\nНаберите в командной строке:
          \nEntLen - подсчет примитивов
          \nMM - масштабный коэффициент и настройка
          \nLPN - результат в новый текст
          \nLPE - результат в существующий текст")
(princ)

[skkkk]

VVA, огромное спасибо! Работает!! Только хотелось бы так:
ввожу "_entLen", выбираю примитивы, enter, кликаю текст для вставки. Реально? И тут нужна точка в разделителе. Забыл сразу сказать. Это мне нужно для задачи, так скажем, № 1. Для другой задачи (условно назовем ее №2) я использую лисп с #62, за что Вам отдельное спасибо. В нем я удалил строчку

Код:

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

(defun c:LP ( )(if (= (type *MIP-LENGTH*) 'REAL)(progn

и стало так: ввожу команду, выбираю объекты, enter и появляется текст с результатом возле курсора(вот здесь мне нужен разделитель-запятая) - все так как надо!!!
А вот с #104 такой вариант не прошел.

[VVA]

Ты сам то не запутаешься где точка, а где нет?
Точка на запятую меняется здесь

Код:

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

 
(vl-string-translate "." ","

Можешь из LPE создать свою команду с точкой. Скопируй код и замени "," на "."

Код:

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

(defun c:LPE1 ( )
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." "."  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 nil))
(princ))

ввожу "_entLen", выбираю примитивы, enter, кликаю текст для вставки. Реально?

Создай кнопку
^C^CENTLEN;LPE;
Или команду

Код:

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

 
(defun C:SKKK ()
  (C:ENTLEN) ;_ Вызов команды ENtlen из лиспа
  (C:LPE)    ;_ Вызов команды LPE из лиспа
  )

По такому образу и подобию наклепай себе команд столько, сколько хочешь или сможешь, только не запутайся

[skkkk]

Спасибо,VVA.А я разобрался, как переделать лисп из #104.

Код:

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

(setq *MIP-MODEMACRO-RTOS* 2)      ;_Округление до 2-х знаков
(setq *MIP-MODEMACRO-SCALE* 0.1) ;_Масштаб 
(setq *MIP-MODEMACRO-HTXT* 2.5) ;_Высота текста

(vl-load-com)
(if (null *MIP-MODEMACRO-HTXT*)(setq *MIP-MODEMACRO-HTXT* 3.0)) ;_Высота текста
(if (null *MIP-MODEMACRO-RTOS*)(setq *MIP-MODEMACRO-RTOS* -1.0));_Округление -1-LUPREC
(if (null *MIP-MODEMACRO-SCALE*)(setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштаб
(VL-PROPAGATE '*MIP-MODEMACRO-HTXT*)
(VL-PROPAGATE '*MIP-MODEMACRO-RTOS*)
(VL-PROPAGATE '*MIP-MODEMACRO-SCALE*)
(defun C:entLen (/ set:entities      int:allEntities 
            int:curveEntities int:l         rea:length 
         )
  (princ "\nТекущий коэффициент K=")(princ (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst))))    ; Этот if добавлен для 
    (setq set:entities (ssget))            ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities 
    (progn 
      (setq int:allEntities 
        (sslength set:entities)   ; количество выбранных примитивов 
       int:curveEntities 
        0            ; счетчик линейных примитивов 
       int:l 0         ; счетчик 
       rea:length 
        0.0         ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities)) 
   (if 
     (not 
       (vl-catch-all-error-p 
         (vl-catch-all-apply 
      'vlax-curve-getStartPoint 
      (list 
        (vlax-ename->vla-object (ssname set:entities int:l)) 
      ) ;_ list 
         ) ;_  vl-catch-all-apply 
       ) ;_  vl-catch-all-error-p 
     ) ;_  not 
      (setq int:curveEntities (1+ int:curveEntities) 
       rea:length      (+ rea:length 
                  (vlax-curve-getDistAtParam 
               (vlax-ename->vla-object 
                 (ssname set:entities int:l) 
               ) ;_ vlax-ename->vla-object 
               (vlax-curve-getEndParam 
                 (ssname set:entities int:l) 
               ) ;_ vlax-curve-getEndParam 
                  ) ;_  vlax-curve-getDistAtParam 
               ) ;_  + 
      ) ;_  setq 
   ) ;_  if 
   (setq int:l (1+ int:l)) 
      ) ;_  while
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (princ (strcat "\n Выбрано примитивов: " 
           (itoa int:allEntities) 
           ", из них линейных: " 
           (itoa int:curveEntities)
           "\nПоправочный коэфиициент K="                     
           "\n Общая длина линейных примитивов: "
        (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))                     
        ) ;_ strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны!") 
  ) ;_  if 
  (prin1) 
(defun TTC_Paste(pasteStr keepText / nslLst vlaObj)
(if (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки <выход>: "))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." "."  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 nil))
(princ))

Настроил кнопку. Теперь нажимаю на нее, выбираю объекты (линии), правый клик (=enter), выбираю текст для вставки оверрайтом(перезапись). Неграмотно?? Но работает.

[skkkk]

VVA, а почему если вставить

Код:

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

(setq *MIP-MODEMACRO-RTOS* 2)      ;_Округление до 2-х знаков
(setq *MIP-MODEMACRO-HTXT* 2.5) ;_Высота текста

в другой лисп, например для подсчета суммы мтекстов, он не округляет как надо, как это делается в лиспах с этой темы, или, поставив вопрос правильнее, может, еще чего-то не хватает? Хочется, чтоб не требуя никаких изменений настроек, каждый лисп писал заданное мной количество нулей после запятой в результате

[VVA]

Как правило округление происходит с помощью функции rtos, а на ее поведение влияет системная переменная dimzin
Перед вызовом лиспа установи dimzin в 0 (setvar "dimzin" 0), а еще лучше запомни предыдущее состояние, устанви в 0, сделай что нужно и восстанови dimzin обратно.
Кстати здесь в #409 выдложен лисп для суммировани и округления текстов.
Команда TORK так и делает: запрашивает кол-во знавок округления и подавлять или нет незначащие 0.
Команды sumTE и sumTN будут суммировать тексты и оставлять незначащие 0, если перед их вызовом установить dimzin в 0.

[skkkk]

VVA, а почему Вы считаете:

...а еще лучше запомни предыдущее состояние, устанви в 0, сделай что нужно и восстанови dimzin обратно

?
Она влияет еще на что-то кроме подавления нулей?? Мне бы наоборот надо чтоб она равнялась нулю, а она часто меняется сама на 8, вроде при открытии другого файла, но я не уверен. Я даже кнопку себе вывел:

Код:

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

^C^C_setvar;dimzin;0

.
И подскажите пожалуйста, какая переменная отвечает за значение точности в меню Формат->Единицы?

[VVA]

Нет, кроме подавления нулей ни на что не влияет. Но давит нули и в размерных стилях тоже.
LUPREC - точность
LUNITS - Тип единиц

[skkkk]

Можно ли как-нибудь вот эти действия заставить выполняться посредством лиспа, а не из командной строки:

Код:

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

^C^C_setvar;dimzin;0
^C^C_setvar;luprec;2?

Другими словами, как их выразить языком лисп?
Хотелось бы их добавить в нужный лисп, назначив, видимо, кнопке макрос

Код:

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

^C^C(Load "лисп.lsp");команда,

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

[Дима_]

Непонятно зачем в командной строке было _setvar использовать - имени переменной вполне хватает. В лиспе это выглядит (setvar "dimzin" 0) (setvar "luprec" 2).

[skkkk]

Дима_, с этим:

В лиспе это выглядит (setvar "dimzin" 0) (setvar "luprec" 2)

-я не разобрался, но нашел вариант:

Код:

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

(command "dimzin" 0)
(command "luprec" 2)

-вставляю это в лисп, и переменные меняются при запуске лиспаподскажите, люди, в чем ошибся мой научный тык
А насчет:

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

-действительно, зачем? Самоучкам тяжко бывает

[skkkk]

VVA, я успешно пользуюсь кодом с поста #107. Но вот возникла мысль, а можно ли его зациклить? То есть, нажимаю кнопку вызова лиспа, выбираю объекты, правая кнопка(=enter), кликаю текст для вставки, и тут же снова появляется приглашение программы выбрать объекты(без повторного вызова команды), и так по кругу с выходом по esc. Пробовал манипуляции с макросом с поста #106(^C^CENTLEN;LPE по аналогии с зацикливанием "break at point" по совету с форума (*^C^C_break;\_f;\@) - ничего не вышло . Может циклить надо в самом лиспе?

[VVA]

Оставь лисп #107 как есть и добавь к нему этот кусочек

Код:

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

(defun C:ENTLEN* ()(while t (C:ENTLEN)))

Вызов ENTLEN*

[skkkk]

VVA, спасибо............. Правда, прежде, чем увидел Ваш ответ, я нашел его на соседнем сайте в теме про изменение цвета текста лиспом, причем, в Вашем же лиспе (http://www.caduser.ru/cgi-bin/f1/board.cgi?t=42402mx)
Эта тема, кстати, меня и заинтересовала изменением цвета текста лиспом. Хочется, чтобы при выборе мтекста для вставки результата, результат записывался белым цветом, при том, что исходный мтекст был другого цвета...Ну понимаете, для того, чтоб было видно, ЧТО я уже обработал, а что - нет. И хотелось бы более ли менее универсальный совет, т.е. чтоб я мог добавить, допустим, код и в другой лисп, например для суммы мтекстов.......
Пробовал как-то совмещать лиспы с кодом из вышеуказанной ссылки, но знаний пока маловато...

[VVA]

skkkk,
Модифицировал код из поста №107

Код:

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

(setq *MIP-MODEMACRO-RTOS* 2)      ;_Округление до 2-х знаков
(setq *MIP-MODEMACRO-SCALE* 0.1) ;_Масштаб 
(setq *MIP-MODEMACRO-HTXT* 2.5) ;_Высота текста

(vl-load-com)
(if (null *MIP-MODEMACRO-HTXT*)(setq *MIP-MODEMACRO-HTXT* 3.0)) ;_Высота текста
(if (null *MIP-MODEMACRO-RTOS*)(setq *MIP-MODEMACRO-RTOS* -1.0));_Округление -1-LUPREC
(if (null *MIP-MODEMACRO-SCALE*)(setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштаб
(VL-PROPAGATE '*MIP-MODEMACRO-HTXT*)
(VL-PROPAGATE '*MIP-MODEMACRO-RTOS*)
(VL-PROPAGATE '*MIP-MODEMACRO-SCALE*)
(defun C:entLen (/ set:entities      int:allEntities 
            int:curveEntities int:l         rea:length 
         )
  (princ "\nТекущий коэффициент K=")(princ (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst))))    ; Этот if добавлен для 
    (setq set:entities (ssget))            ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities 
    (progn 
      (setq int:allEntities 
        (sslength set:entities)   ; количество выбранных примитивов 
       int:curveEntities 
        0            ; счетчик линейных примитивов 
       int:l 0         ; счетчик 
       rea:length 
        0.0         ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities)) 
   (if 
     (not 
       (vl-catch-all-error-p 
         (vl-catch-all-apply 
      'vlax-curve-getStartPoint 
      (list 
        (vlax-ename->vla-object (ssname set:entities int:l)) 
      ) ;_ list 
         ) ;_  vl-catch-all-apply 
       ) ;_  vl-catch-all-error-p 
     ) ;_  not 
      (setq int:curveEntities (1+ int:curveEntities) 
       rea:length      (+ rea:length 
                  (vlax-curve-getDistAtParam 
               (vlax-ename->vla-object 
                 (ssname set:entities int:l) 
               ) ;_ vlax-ename->vla-object 
               (vlax-curve-getEndParam 
                 (ssname set:entities int:l) 
               ) ;_ vlax-curve-getEndParam 
                  ) ;_  vlax-curve-getDistAtParam 
               ) ;_  + 
      ) ;_  setq 
   ) ;_  if 
   (setq int:l (1+ int:l)) 
      ) ;_  while
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (princ (strcat "\n Выбрано примитивов: " 
           (itoa int:allEntities) 
           ", из них линейных: " 
           (itoa int:curveEntities)
           "\nПоправочный коэфиициент K="                     
           "\n Общая длина линейных примитивов: "
        (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))                     
        ) ;_ strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны!") 
  ) ;_  if 
  (prin1) 
(defun TTC_Paste(pasteStr keepText / nslLst vlaObj)
(if (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки <выход>: "))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p
      (vl-catch-all-apply
	'(lambda()
	   (vla-put-TextString vlaObj pasteStr)
	   (vla-put-Color vlaObj 3)  ;3-номер цвета
	   )
	)
      )
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." "."  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 nil))
(princ))

Нужное выделено красным цветом

[skkkk]

VVA, дай Бог Вам детишек смышленных и веселых......Как всегда круто Еще бы один штришок....Как сделать, чтоб при вызове функции entlen выбрать только одну линию, а следующим кликом левой кнопки на текст перезаписывать его значение? Т.е. чтобы enter нажимался автоматом после выбора одной линии. Куда-то надо вставить двойные кавычки?? Только пробовал я это - не вышло

[VVA]

Код:

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

(setq *MIP-MODEMACRO-RTOS* 2)      ;_Округление до 2-х знаков
(setq *MIP-MODEMACRO-SCALE* 0.1) ;_Масштаб 
(setq *MIP-MODEMACRO-HTXT* 2.5) ;_Высота текста

(vl-load-com)
(if (null *MIP-MODEMACRO-HTXT*)(setq *MIP-MODEMACRO-HTXT* 3.0)) ;_Высота текста
(if (null *MIP-MODEMACRO-RTOS*)(setq *MIP-MODEMACRO-RTOS* -1.0));_Округление -1-LUPREC
(if (null *MIP-MODEMACRO-SCALE*)(setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштаб
(VL-PROPAGATE '*MIP-MODEMACRO-HTXT*)
(VL-PROPAGATE '*MIP-MODEMACRO-RTOS*)
(VL-PROPAGATE '*MIP-MODEMACRO-SCALE*)
(defun C:entLen1 (/ set:entities      int:allEntities 
            int:curveEntities int:l         rea:length 
         )
  (princ "\nТекущий коэффициент K=")(princ (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst))))    ; Этот if добавлен для 
    (setq set:entities (ssget "_:E:S"))            ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities 
    (progn 
      (setq int:allEntities 
        (sslength set:entities)   ; количество выбранных примитивов 
       int:curveEntities 
        0            ; счетчик линейных примитивов 
       int:l 0         ; счетчик 
       rea:length 
        0.0         ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities)) 
   (if 
     (not 
       (vl-catch-all-error-p 
         (vl-catch-all-apply 
      'vlax-curve-getStartPoint 
      (list 
        (vlax-ename->vla-object (ssname set:entities int:l)) 
      ) ;_ list 
         ) ;_  vl-catch-all-apply 
       ) ;_  vl-catch-all-error-p 
     ) ;_  not 
      (setq int:curveEntities (1+ int:curveEntities) 
       rea:length      (+ rea:length 
                  (vlax-curve-getDistAtParam 
               (vlax-ename->vla-object 
                 (ssname set:entities int:l) 
               ) ;_ vlax-ename->vla-object 
               (vlax-curve-getEndParam 
                 (ssname set:entities int:l) 
               ) ;_ vlax-curve-getEndParam 
                  ) ;_  vlax-curve-getDistAtParam 
               ) ;_  + 
      ) ;_  setq 
   ) ;_  if 
   (setq int:l (1+ int:l)) 
      ) ;_  while
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (princ (strcat "\n Выбрано примитивов: " 
           (itoa int:allEntities) 
           ", из них линейных: " 
           (itoa int:curveEntities)
           "\nПоправочный коэфиициент K="                     
           "\n Общая длина линейных примитивов: "
        (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))                     
        ) ;_ strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны!") 
  ) ;_  if 
  (prin1) 
(defun TTC_Paste(pasteStr keepText / nslLst vlaObj)
(if (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки <выход>: "))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p
      (vl-catch-all-apply
	'(lambda()
	   (vla-put-TextString vlaObj pasteStr)
	   (vla-put-Color vlaObj 3)  ;3-номер цвета
	   )
	)
      )
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." "."  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 nil))
(princ))

[dextron3]

сделали

[skkkk]

VVA, а реально лиспом сделать следующее? Есть некое количество вертикальных отрезков. Под каждым снизу с небольшим смещением расположены вертикально ориентированные мтексты. Выделить скопом все отрезки, затем выделить все тексты. И чтобы длина каждой линии отобразилась с коэффициентом в "своем", т.е. близлежащем тексте. Расстояние между отрезками разное.

[skkkk]

Расстояние наверное не будет играть роль, если алгоритм будет основан на поочередной обработке объектов, сначала отрезки(первый, второй.....n-ый), потом мтексты (первый, второй.....n-ый)

[vsegdasam]

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

[Кулик Алексей aka kpblc]

dwg.ru/art/8
+ FAQ

[skkkk]

Господа Гуру, подскажите пожалуйста, как можно значение суммы длин линий слоя связать с полем либо с ячейкой таблицы, то есть, чтобы в поле или ячейке динамически отображалась эта величина?

[VVA]

skkkk, Читай здесь Связь графических объектов и текста

[skkkk]

VVA, а по поводу #122 не сможете подсказать?

[samogonshik]

извините, а как все это внедрить в программу?

[Кулик Алексей aka kpblc]

См.подпись VVA.

[Аннагельды]

Подскажите пожалуйста как подсчитать сумму отрезков длин и как использовать LIPS

[Кулик Алексей aka kpblc]

На один пост вверх посмотри.

[Игорь Костюкович]

Сообщение от Аннагельды ... и как использовать LIPS

LIPS - губы (англ.) Неужели нужна инструкция по эксплуатации?
У модераторов прошу отдельного пардону за офф. Не сдержался...

[Shish]

Не подскажете, в чем проблема:

Команда: (entlen)
найдено: 38
; ошибка: no function definition: VLAX-ENAME->VLA-OBJECT

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

Сообщение от Shish Не подскажете, в чем проблема: Команда: (entlen) найдено: 38 ; ошибка: no function definition: VLAX-ENAME->VLA-OBJECT

выполни команду (vl-load-com) и почитай Как использовать код на Лиспе

[Shish]

У меня lisp с этой команды начинается. Kos об этом позаботился.

http://forum.dwg.ru/showpost.php?p=24124&postcount=42

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

Shish, выполни две команды:

Код:

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

(_VER)
(ver)

результат выложи посмотреть. Буду медитировать дальше.

[Shish]

Команда: (_VER)
"RTS v.5.0a0-20b"

Команда: (ver)
"Visual LISP 2008 (ru)"

Спасибо за заботу!

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

попробуй еще:

Код:

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

(eval vlax-ename->vla-object)

Похоже, у тебя сбой в библиотеках автокада...

[Shish]

Команда: (eval vlax-ename->vla-object)
nil

А Entlen по-прежнему выдает ошибку.

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

Сообщение от Shish Команда: (eval vlax-ename->vla-object) nil

Самое быстрое и простое решение в данном случае - переустановка автокада...

[Shish]

Блин, плохо... Кнопочки, цвета, крестики, все ж опять настраивать... Можно все настройки каким-нибудь одним файлом сохранить? Понимаю, что можно и F1 нажать, но... лень.

Жень, спасибо за помощь! Переустановил, все работает. Рабочее пространство сохранил мастером переноса пользовательских настроек.

[Aндрeй]

Как все-таки коэффициент менять, только в коде?
мм не работает...

[skkkk]

Андрей, нельзя ли подробнее вопрос поставить?

[Aндрeй]

Сообщение от skkkk Андрей, нельзя ли подробнее вопрос поставить?

Как задается масштаб?
Только в коде, изменением *MIP-MODEMACRO-SCALE*?
Либо есть еще какие-то варианты после запуска?

[VVA]

Сообщение от Aндрeй Как задается масштаб? Только в коде, изменением *MIP-MODEMACRO-SCALE*? Либо есть еще какие-то варианты после запуска?

Есть. Уточни, из какого поста скопировал код? В #104 есть команды

(princ "\nНаберите в командной строке: \nEntLen - подсчет примитивов \nMM - масштабный коэффициент и настройка \nLPN - результат в новый текст \nLPE - результат в существующий текст")

В принципе можно докопировать команду к своему коду.

[ktstar]

Установите Веткад... Там есть "суперкалькулятор". У него есть функция суммирование длин линий, дуг, окружностей, разбросанных по всему чертежу.... У меня стоит версия 3.3

[DiF]

Добрый день! Подскажите пожалуйста.
Есть чертеж, схема сети, на ней разными слоями нанесены емкости кабелей.
Необходимо сосчитать их суммарную длину и умножить на некий коэффициент, который соответствует реальному расстоянию.

Можно это как то сделать автоматически?

На первой взяд lips, он отлично считает выбеленные отрезки, но может быть как-то можно выделить сразу все отрезки одного слоя на модели?
Спасибо большое!

[Nike]

Сообщение от DiF может быть как-то можно выделить сразу все отрезки одного слоя на модели

(ssget "_x" '((0 . "LINE") (410 . "Model") (8 . Имя слоя")))

[VVA]

Сообщение от DiF Есть чертеж, схема сети, на ней разными слоями нанесены емкости кабелей. Необходимо сосчитать их суммарную длину и умножить на некий коэффициент, который соответствует реальному расстоянию.

Команда MLEN41
Остальные варианты LISP. Подсчет длины линий на определенном слое

Код:

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

;;;http://www.caduser.ru/forum/index.php?PAGE_NAME=message&FID=44&TID=20298&PAGEN_1=3
;|================== XLS ========================================
* Опубликовано http://www.caduser.ru/forum/index.php...&TID=19920
               http://www.caduser.ru/forum/index.php...&TID=31444
               http://www.caduser.ru/forum/index.php...&TID=31669
* Автор: Владимир Азарко 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

[DiF]

Спасибо. Спасибо огромное. =)

[AutoS]

Всем привет.
Нужна программа на LISP, которая будет подсчитывать количество примитивов в каждом слое и потом записывать все это в XLS файл.
Заранее Большое Спасибо.

[Кулик Алексей aka kpblc]

_.qselect, выписать на бумажку, вбить в ексль.
Большое Пожалста.

[AutoS]

Спасибо.
Это вроде как не подходит..
Например если имеется 100+ слоев..
Нужна программка которая пере клацает все слои и впишет количество примитивов под именем каждого слоя в XLS файл..
Спасибо еще раз..

[Кулик Алексей aka kpblc]

Есть пара встречных вопросов:
1. А как быть с примитивами, которые находятся внутри блоков или внешних ссылок?
2. Что сделано самостоятельно и на чем спотык?

[AutoS]

1- В блоках считать, в ссылках- нет (про ссылки не понял).
2- Недавний юзер AutoCAD и только только начинаю учить LISP.
В таких закидонах не силен, и потому и спрашиваю у профессионалов..

[Nike]

AutoS, нафига тебе лисп? Запусти "Извлечение данных" и сортируй по любому параметру,

[VVA]

AutoS, Команду MLEN41 из #150 смотрел?

[AutoS]

VVA, смотрел, работает классно, вот только количества для каждого слоя там нет..
Было Бы очень хорошо, чтобы после столбца со слоями шел столбец с количеством, а потом длинна..
В любом случае Большое Вам Спасибо.

[dew]

ребята а можно переделать данный код чтобы результат можно было бы вставить в таблицу (в нужную ячейку) на чертеже

Код:

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

(setq *MIP-MODEMACRO-RTOS* 2)      ;_Округление до 2-х знаков
(setq *MIP-MODEMACRO-SCALE* 0.1) ;_Масштаб 
(setq *MIP-MODEMACRO-HTXT* 2.5) ;_Высота текста

(vl-load-com)
(if (null *MIP-MODEMACRO-HTXT*)(setq *MIP-MODEMACRO-HTXT* 3.0)) ;_Высота текста
(if (null *MIP-MODEMACRO-RTOS*)(setq *MIP-MODEMACRO-RTOS* -1.0));_Округление -1-LUPREC
(if (null *MIP-MODEMACRO-SCALE*)(setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштаб
(VL-PROPAGATE '*MIP-MODEMACRO-HTXT*)
(VL-PROPAGATE '*MIP-MODEMACRO-RTOS*)
(VL-PROPAGATE '*MIP-MODEMACRO-SCALE*)
(defun C:entLen1 (/ set:entities      int:allEntities 
            int:curveEntities int:l        rea:length 
        )
  (princ "\nТекущий коэффициент K=")(princ (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst))))    ; Этот if добавлен для 
    (setq set:entities (ssget "_:E:S"))            ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities 
    (progn 
      (setq int:allEntities 
        (sslength set:entities)  ; количество выбранных примитивов 
      int:curveEntities 
        0            ; счетчик линейных примитивов 
      int:l 0        ; счетчик 
      rea:length 
        0.0        ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities)) 
  (if 
    (not 
      (vl-catch-all-error-p 
        (vl-catch-all-apply 
      'vlax-curve-getStartPoint 
      (list 
        (vlax-ename->vla-object (ssname set:entities int:l)) 
      ) ;_ list 
        ) ;_  vl-catch-all-apply 
      ) ;_  vl-catch-all-error-p 
    ) ;_  not 
      (setq int:curveEntities (1+ int:curveEntities) 
      rea:length      (+ rea:length 
                  (vlax-curve-getDistAtParam 
              (vlax-ename->vla-object 
                (ssname set:entities int:l) 
              ) ;_ vlax-ename->vla-object 
              (vlax-curve-getEndParam 
                (ssname set:entities int:l) 
              ) ;_ vlax-curve-getEndParam 
                  ) ;_  vlax-curve-getDistAtParam 
              ) ;_  + 
      ) ;_  setq 
  ) ;_  if 
  (setq int:l (1+ int:l)) 
      ) ;_  while
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (princ (strcat "\n Выбрано примитивов: " 
          (itoa int:allEntities) 
          ", из них линейных: " 
          (itoa int:curveEntities)
          "\nПоправочный коэфиициент K="                    
          "\n Общая длина линейных примитивов: "
        (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))                    
        ) ;_ strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны!") 
  ) ;_  if 
  (prin1) 
(defun TTC_Paste(pasteStr keepText / nslLst vlaObj)
(if (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки <выход>: "))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p
      (vl-catch-all-apply
        '(lambda()
          (vla-put-TextString vlaObj pasteStr)
          (vla-put-Color vlaObj 3)  ;3-номер цвета
          )
        )
      )
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." "."  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 nil))
(princ))

[Vilen]

Сообщение от dew ребята а можно переделать данный код чтобы результат можно было бы вставить в таблицу (в нужную ячейку) на чертеже Код: [Выделить все] (setq *MIP-MODEMACRO-RTOS* 2) ;_Округление до 2-х знаков (setq *MIP-MODEMACRO-SCALE* 0.1) ;_Масштаб (setq *MIP-MODEMACRO-HTXT* 2.5) ;_Высота текста (vl-load-com) (if (null *MIP-MODEMACRO-HTXT*)(setq *MIP-MODEMACRO-HTXT* 3.0)) ;_Высота текста (if (null *MIP-MODEMACRO-RTOS*)(setq *MIP-MODEMACRO-RTOS* -1.0));_Округление -1-LUPREC (if (null *MIP-MODEMACRO-SCALE*)(setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштаб (VL-PROPAGATE '*MIP-MODEMACRO-HTXT*) (VL-PROPAGATE '*MIP-MODEMACRO-RTOS*) (VL-PROPAGATE '*MIP-MODEMACRO-SCALE*) (defun C:entLen1 (/ set:entities int:allEntities int:curveEntities int:l rea:length ) (princ "\nТекущий коэффициент K=")(princ (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*)) (if (not (setq set:entities (cadr (ssgetfirst)))) ; Этот if добавлен для (setq set:entities (ssget "_:E:S")) ; обработки предварительного ) ;_ if ; выбора примитивов (if set:entities (progn (setq int:allEntities (sslength set:entities) ; количество выбранных примитивов int:curveEntities 0 ; счетчик линейных примитивов int:l 0 ; счетчик rea:length 0.0 ; общая длина линейных примитивов ) ;_ setq (while (< int:l (sslength set:entities)) (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getStartPoint (list (vlax-ename->vla-object (ssname set:entities int:l)) ) ;_ list ) ;_ vl-catch-all-apply ) ;_ vl-catch-all-error-p ) ;_ not (setq int:curveEntities (1+ int:curveEntities) rea:length (+ rea:length (vlax-curve-getDistAtParam (vlax-ename->vla-object (ssname set:entities int:l) ) ;_ vlax-ename->vla-object (vlax-curve-getEndParam (ssname set:entities int:l) ) ;_ vlax-curve-getEndParam ) ;_ vlax-curve-getDistAtParam ) ;_ + ) ;_ setq ) ;_ if (setq int:l (1+ int:l)) ) ;_ while (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length)) (princ (strcat "\n Выбрано примитивов: " (itoa int:allEntities) ", из них линейных: " (itoa int:curveEntities) "\nПоправочный коэфиициент K=" "\n Общая длина линейных примитивов: " (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)) ) ;_ strcat ) ;_ princ ) ;_ progn (alert "Примитивы не выбраны!") ) ;_ if (prin1) (defun TTC_Paste(pasteStr keepText / nslLst vlaObj) (if (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки <выход>: ")) (progn (cond ((and (= 4(length nslLst)) (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and (setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst))))))) (setq oldStat (vla-get-Measurement vlaObj)) (if keepText (if (= (vla-get-TextOverride vlaObj) "") (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj)))) (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj))))) (if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr))) (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1 ((and (= 4(length nslLst)) (= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and (setq vlaObj (vlax-ename->vla-object(car nslLst))) (if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj)))) (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr))) (princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2 ((and (= 4(length nslLst)) (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and (princ "\nCan't paste to block's DText or MText. ")); end condition #3 ((and (= 2(length nslLst)) (member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and (setq vlaObj (vlax-ename->vla-object(car nslLst))) (if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj)))) (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda() (vla-put-TextString vlaObj pasteStr) (vla-put-Color vlaObj 3) ;3-номер цвета ) ) ) (princ "\nError. Can't pase text. "))); end condition #4 (T (princ "\nCan't paste. Invalid object. ")); end condition #5 ); end cond T); end progn nil); end if );_TTC_PASTE (and (= (type *MIP-LENGTH*) 'REAL) (TTC_Paste (vl-string-translate "." "." (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))) nil)) (princ))

присоединяюсь к просьбе.
если решение уже найдено, поделитесь пожалуйста, спасибо!

[VVA]

Vilen, А этот вариант не подойдет?

Код:

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

(setq *MIP-MODEMACRO-RTOS* 2)      ;_Округление до 2-х знаков
(setq *MIP-MODEMACRO-SCALE* 0.1) ;_Масштаб 
(setq *MIP-MODEMACRO-HTXT* 2.5) ;_Высота текста

(vl-load-com)
(if (null *MIP-MODEMACRO-HTXT*)(setq *MIP-MODEMACRO-HTXT* 3.0)) ;_Высота текста
(if (null *MIP-MODEMACRO-RTOS*)(setq *MIP-MODEMACRO-RTOS* -1.0));_Округление -1-LUPREC
(if (null *MIP-MODEMACRO-SCALE*)(setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштаб
(VL-PROPAGATE '*MIP-MODEMACRO-HTXT*)
(VL-PROPAGATE '*MIP-MODEMACRO-RTOS*)
(VL-PROPAGATE '*MIP-MODEMACRO-SCALE*)
(defun C:entLen1 (/ set:entities      int:allEntities 
            int:curveEntities int:l        rea:length 
        )
  (princ "\nТекущий коэффициент K=")(princ (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst))))    ; Этот if добавлен для 
    (setq set:entities (ssget "_:E:S"))            ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities 
    (progn 
      (setq int:allEntities 
        (sslength set:entities)  ; количество выбранных примитивов 
      int:curveEntities 
        0            ; счетчик линейных примитивов 
      int:l 0        ; счетчик 
      rea:length 
        0.0        ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities)) 
  (if 
    (not 
      (vl-catch-all-error-p 
        (vl-catch-all-apply 
      'vlax-curve-getStartPoint 
      (list 
        (vlax-ename->vla-object (ssname set:entities int:l)) 
      ) ;_ list 
        ) ;_  vl-catch-all-apply 
      ) ;_  vl-catch-all-error-p 
    ) ;_  not 
      (setq int:curveEntities (1+ int:curveEntities) 
      rea:length      (+ rea:length 
                  (vlax-curve-getDistAtParam 
              (vlax-ename->vla-object 
                (ssname set:entities int:l) 
              ) ;_ vlax-ename->vla-object 
              (vlax-curve-getEndParam 
                (ssname set:entities int:l) 
              ) ;_ vlax-curve-getEndParam 
                  ) ;_  vlax-curve-getDistAtParam 
              ) ;_  + 
      ) ;_  setq 
  ) ;_  if 
  (setq int:l (1+ int:l)) 
      ) ;_  while
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (princ (strcat "\n Выбрано примитивов: " 
          (itoa int:allEntities) 
          ", из них линейных: " 
          (itoa int:curveEntities)
          "\nПоправочный коэфиициент K="                    
          "\n Общая длина линейных примитивов: "
        (rtos *MIP-LENGTH* 2 (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*))                    
        ) ;_ strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны!") 
  ) ;_  if 
  (prin1) 
(defun TTC_Paste(pasteStr keepText / nslLst vlaObj tblobj tblset pt row col lst)
(if (progn
      (initget "T Т _T T")
      (setq nslLst(nentsel "\nТекст, атрибут или размер для вставки или [ячейка Таблицы] <выход>: "))
      (if (not(listp nslLst))(setq nslLst (list nslLst)))
      )
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p
      (vl-catch-all-apply
        '(lambda()
          (vla-put-TextString vlaObj pasteStr)
          (vla-put-Color vlaObj 3)  ;3-номер цвета
          )
        )
      )
(princ "\nError. Can't pase text. "))); end condition #4
((and (= 1(length nslLst))(eq (car nslLst) "T"))
 (initget 1)
 (setq pt (getpoint "\nPick poit in table sell: "))
 (and
 ;_Проверяем, попала ли точка в ячейку таблицы
      (setq  tblobj nil tblset (ssget "_X" (list (cons 0  "ACAD_TABLE")(cons 410 (getvar "CTAB")))))
      (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
      (mapcar '(lambda (x)
           (or tblobj
               (and
                 (= :vlax-true (vla-HitTest x
                               (vlax-3d-point (trans pt 1 0))
                               (vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
                               'row 'col))
                 (setq tblobj x)
                 )))
        lst)
      tblobj row col
      (vla-SetText tblobj row col pasteStr))); end condition #5
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." "."  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 nil))
(princ))

Команда: entlen1 Текущий коэффициент K=0.1 Выберите объекты: Выбрано примитивов: 1, из них линейных: 1 Поправочный коэффициент K= Общая длина линейных примитивов: 13.32 Текст, атрибут или размер для вставки или [ячейка Таблицы] <выход>: Т Pick poit in table sell: Команда:

[Рyslan]

Всем привет. Есть рельеф земли в виде полилинии, нужно посчитать расстояние по рельефу. То есть на каждом участке суммировать с предыдущим. Смотрел здесь http://forum.dwg.ru/showpost.php?p=734502&postcount=19 но что то никак не выбрал нужную. Подскажите, пожалуйста. 4 км считать вручную через свойства тяжко

[Boxa]

Рyslan, после просмотра файла сложилось впечатление, что Вам ведь не посчитать суммарную длину нужно (такого рода скриптов море), а вывести расстояние от начальной точки, до конца каждого отрезка, строго соблюдая последовательность и рельеф. А это несколько другая задача.

[Рyslan]

Да да, на каждом участке рельефа сумма предыдущего и данного участка 0, 0+20, 0+20+30, 0+20+50 и так далее. И участки могут быть разной длины. Вообще рельеф идет одной полилинией. Я просто разбил ее, хотел считать вручную. Потом стал искать лисп. Пока что в Веткаде спецкалькулятором тренируюсь. Но тут текст еще корректировать нужно, поворачивать его . Но он действительно суммирует длины по участкам, уже легче

[Boxa]

Я бы попробовал без всякого программирования, порезанные отрезки загнать в ексель (_DATAEXTRACTION), с длиной и координатой Х начальной точки, отсортировал бы по координате и потом бы, в нижних ячейках просуммировал бы длины как нужно и вставил бы таблицу в акад, растянув и задав соответствующее форматирование.
Прошу прощения, стандартный DATAEXTRACTION координаты вершин полилинии не возващает.

[Рyslan]

Можно попробовать. Возиться с этим экселем не охота. Я тут недавно пользовался программкой NumInc, отлично значение текста суммирует, можно массивом через интервал текст вставлять. Вот такое бы и сюда для подсчета

[skkkk]

Рyslan, на профиле ведь обычно считают расстояние по горизонтали - пикетаж? Если так, то есть простое решение. Правильно ли я понял, что нужно записывать длину наклонных линий, а не их горизонтальное проложение?

[Рyslan]

Сообщение от skkkk на профиле ведь обычно считают расстояние по горизонтали - пикетаж?

Есть расстояния между объектами (линейные), есть расстояние по рельефу. Да нужны "наклонные полилинии", причем еще рельеф (полилинию) разбить нужно по участкам)

Вот сейчас спецкалькулятором один профиль посчитал по рельефу, конечно быстрее чем через свойства, но...может можно еще быстрее

[P_S]

Задача ещё усложняется различием вертикального и горизонтального масштабов профиля.

[Рyslan]

Сообщение от P_S Задача ещё усложняется различием вертикального и горизонтального масштабов профиля.

Масштаб не важен. если что по горизонтали полилинию отмасштабирую. главное чтоб 1:1 считал.

[skkkk]

Рyslan, набросал наскоро, бегло потестировал, вроде полет нормальный.
Сначала (временно) убираем в сторону все вертикальные объекты, не то обработает все не так, как надо (не стал делать их обработку). Затем указываем точку, от которой берется Y-координата для вставки текстов, затем указываем начальную точку (самую первую вершину первой линии, где 0.000).

Код:

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

 (vl-load-com)
(defun C:TEST ( / *error* oldDIMZIN ins_pt Y pt en len zoom_flag  txt_obj txt_obj_pt move_pt ss)
	(defun *error* (msg)
		(if oldDIMZIN (setvar "DIMZIN" oldDIMZIN))
		(if zoom_flag (vla-ZoomPrevious (vlax-get-acad-object)))
	)
	(setq oldDIMZIN (getvar "DIMZIN")
		  ins_pt (getpoint "\nУкажите Y-координату расположения текстов: ")
		  Y (cadr ins_pt)
		  pt (getpoint "\nУкажите стартовую точку: ")
		  ins_pt (list (car pt) Y 0.0)
		  en T
	)
	(setq len (getreal "\nВведите стартовую длину: <0.00>"))
	(if (null len) (setq len 0))
	(if (and ins_pt pt)
		(progn
			(vla-ZoomAll (vlax-get-acad-object))
			(setq zoom_flag T)
		)
	)
	(setvar "DIMZIN" 0)
	(while (and pt ins_pt en)
		(or (setq len len) (setq len 0))
		(setq txt_obj 
			(vla-AddMText 
				(vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object)))
				(vlax-3d-point ins_pt)
				0
				(vl-string-subst "," "." (rtos len 2 2))
			)
		)
		(vla-put-AttachmentPoint txt_obj 4)
		(vla-put-Rotation txt_obj (/ pi 2))
		(setq txt_obj_pt (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint txt_obj)))
			  move_pt (list (car txt_obj_pt) Y 0.0)
		)
		(vla-Move txt_obj (vlax-3D-point txt_obj_pt) (vlax-3D-point move_pt))
		(setq ss 
			(ssget 
				"_C"
				(polar pt (/ pi 4) 0.01)
				(polar pt (/ (* 5 pi) 4) 0.01)
				(list (cons 0 "LWPOLYLINE"))
			)
		)
		(if (and en (= (type en) 'ENAME)) (setq ss (ssdel en ss)))
		(setq en (ssname ss 0))
		(if en 
			(setq pt (vlax-curve-getEndPoint en)
				  len 
					(if len
						(+ len (vlax-curve-getDistAtPoint en pt))
						(vlax-curve-getDistAtPoint en pt)
					)
				  ins_pt (list (car pt) Y 0.0)
			)
		)
	)
	(*error* nil)
)

Результат во вложении.

----- добавлено через ~6 мин. -----

Сообщение от Рyslan причем еще рельеф (полилинию) разбить нужно по участкам

LISP. Разорвать объекты в точках пересечения. BreakObjects.

----- добавлено через ~22 мин. -----
Посмотрел скрин-пример в #169 - стало ясно, что не нужно везде делать префикс "0.000+", да и два знака после запятой там. Исправил

[Рyslan]

skkkk Супер, спасибо! А можно еще добавить выбор, чтобы не всегда с 0 считала, а с выбранной цифры?

[skkkk]

Рyslan, а как? С выбранного места она считает с любого, но первое число - 0. Как проге "объяснить", сколько было до этого линий, и какая стартовая длина? В число первых запросов добавить выбор объекта (текстового) из которого возьмется начальная длина? Или просто запросить число?

[Рyslan]

Сообщение от skkkk Или просто запросить число?

Ладно, что-то я наглею ))) Пусть так останется. Вот у меня например 3 профиля, первый я разбил и от 0 посчитал. Вторую полилинию стыкую с первой, также разбиваю, убираю подсчет от 0 и заново уже две линии считаю, точно также с третьей. Тогда все цифры получаются по порядку, просто их потом на разные профиля раскидал. Большое пребольшое спасибо!!! То что я полдня обсчитывал, твоя программа сделала за 15 минут

[skkkk]

Сообщение от Рyslan Ладно, что-то я наглею )))

Ладно уж, это ж мелочи
Добавил запрос стартовой длины. Если на этот запрос нажать Enter, то будет ноль.
Обновил в #172.
Если будет удобнее, можно вместо ввода длины взять ее с текста. Это несложно.

----- добавлено через ~8 мин. -----
Тут есть еще один момент. Надо, чтобы направление полилинии, обозначающей поверхность земли, до разбивки на куски по 20 м (по горизонтали) было слева направо. Проверить можно, выбрав полилинию и потыкать пункт "Вершины" в свойствах. Обратить - с помощью _PEDIT. Просто прога сканирует у каждого куска (разбитой полилинии) вершины от левой к правой (от начальной к конечной), берет новый кусок справа, ставит его длину - и так, пока не кончатся куски.

[Рyslan]

Спасибо! Я понял, я ее недавно Оверкилом чистил. Я вот щас сравнил первый вариант со вторым, почему то пересчет был с разницей 0,01. Обрати внимание на последнюю длину

[VVA]

Сообщение от skkkk Надо, чтобы направление полилинии, обозначающей поверхность земли, до разбивки на куски по 20 м (по горизонтали) было слева направо

Не проблема перед применением твоей программы проверить и реверсировать, при необходимости, все полилинии по часовой как отдельной командой, так и включив пару функций в твой код
http://www.cadtutor.net/forum/showth...l=1#post405249

[skkkk]

VVA, никак не возьму в толк: что значит "по часовой". С замкнутыми - ясно, а вот у меня строго горизонтальная полилиния с направлением обхода слева на право. Она - по часовой или против в данном контексте? Или сверху вниз - она как? Как-то пытался связаться с этим "клоквайзом", чтобы определить угол поворота полилинии - влево или вправо по ходу движения (кажется, нашел функцию Евгения Елпанова) - сломал весь мозг, с моей логикой она не увязалась, и я сделал по-другому. Попробовал коды из твоей ссылки - еще больше сбился с толку. PL-CW вообще ничего не делает, а PL-CCW меняет направление на обратное. А как сделать по-любому слева направо, так и не понял.

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

----- добавлено через ~21 мин. -----

Сообщение от Рyslan Я вот щас сравнил первый вариант со вторым, почему то пересчет был с разницей 0,01. Обрати внимание на последнюю длину

Только сейчас увидел эту дописку. Разница в 0.01 - это старая как мир (программирования) проблема - результат вычислений над числами с плавающей запятой. Ты в первый раз скорее всего прогнал прогой весь профиль, а второй - по частям, вводя на началах разбитых фрагментов длину с клавиатуры с двумя знаками после запятой. В первом случае третий знак после запятой не пишется, но участвует в расчетах. И в сумме он может дать, например, 0.004 или 0.005. При округлении до двух знаков третий знак теряется, и не складывается далее с последующими, округляясь по математическим правилам: 0.04 -> 0.0, а 0.05 -> 0.1. Во втором случае третий знак потерялся, и не просуммировался с последующими значениями, поэтому и разница в 0.1. Чтобы этого избежать, надо в расчетах брать не все знаки после запятой, а переводить обратно в число строку, которая вписывается в текст. Конечно, тысячная метра для геодезии - фигня, но осадок остается, и некоторые придирчивые проверялы прям потирают ручки при виде подобных оплошностей. Подправлю по возможности, вместе с обработкой направления полилиний, когда пойму, как это сделать.

[VVA]

Сообщение от skkkk чтобы определить угол поворота полилинии - влево или вправо по ходу движения

Здесь выложил функцию D. C. Broad, Jr. sideof

Сообщение от VVA ;;; D. C. Broad, Jr. ;;; (sideof <ray-origin> <another-point-on-ray> <point-to-be-tested>) ;;; return values ;;; negative = point is to the right side of the ray ;;; 0 = point is on the ray ;;; otherwise point is on the left side of the ray. ;;; P1 should not equal P2 for meaningful results.

Позволяет узнать, справа или слева от луча находится проверяемая точка
По поводу PL-CW, PL-CCW - в основе код Евгения Елпанова, корни нужно искать на caduser'e и там, по моему, для точного определения направления нужно 3 точки.

Сообщение от skkkk PL-CW вообще ничего не делает

Значит считается, что обход линии идет по часовой и нет необходимости реверсировать линию

Сообщение от skkkk PL-CCW меняет направление на обратное

Значит считается, что обход линии идет по часовой и нужно реверсировать линию

[skkkk]

Сообщение от VVA Значит считается, что обход линии идет по часовой и нет необходимости реверсировать линию

В том то и дело, что я пытался эти команды применять к горизонтальной полилинии, которую реверсировал вручную, а затем применял эти команды. Первая ничего не делает, как бы я линию не повернул. А вторая - реверсирует, тоже, как бы я ее не повернул. Вот тебе, бабушка, и Юрьев день
Где я и что делаю не так?
В контексте последнего кода подумываю над тем, чтобы просто проверять, на каждой новой полилинии в цикле, начало ли полилинии "нащупалось", и если нет, то просто реверсировать ее.

[P_S]

По-моему, что-то вы перемудрили. Исходная задача какая: есть единая полилиния рельефа, и надо записать в графе профиля расстояния по ней с определённым шагом по пикетажу. Это можно сделать в одном цикле, и не надо ничего рвать и выбирать каждый раз новую полилинию. Направление исходной, конечно, надо проверить.
В общем, какой-то такой функционал получается:

Код:

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

 (princ "\nУкажите линию рельефа")
(setq graf    (vlax-ename->vla-object
                (ssname (ssget "_:S" '((0 . "LWPOLYLINE"))) 0))
      step    (getint "Введите шаг:  ")
      ins_pt  (cadr (getpoint "\nУкажите Y-координату начала строк: "))
      m_sp    (vla-get-ModelSpace
                (vla-get-ActiveDocument (vlax-get-acad-object)))
      t_const (append
                '((0 . "TEXT")
                  (100 . "AcDbEntity")
                  (67 . 0)
                  (410 . "Model")
                  (100 . "AcDbText")
                  (50 . 1.5708))
                (list (cons 40 (getreal "\nВведите высоту текста:  ")))
                '((41 . 1.0)
                  (51 . 0.0)
                  (7 . "Standard")
                  (71 . 0)
                  (72 . 0))) ;DXF-коды, общие для всех текстовых меток
      begin   (vlax-curve-getStartPoint graf)
      )
(entmakex (append t_const
                  (list (cons 1 "0.00")
                        (list 10 (car begin) ins_pt 0.0))))
(setq begin (list (+ step (car begin)) (cadr begin)))
(while (setq per
              (vlax-variant-value
                (vla-IntersectWith
                  graf
                  (vla-AddLightWeightPolyline
                    m_sp
                    (vlax-safearray-fill
                      (vlax-make-safearray vlax-vbDouble '(0 . 3))
                      (list (car begin)
                            (- (cadr begin) 1000)
                            (car begin)
                            (+ (cadr begin) 1000))))
                  acExtendOtherEntity)))
  (entdel (entlast))
  (entmakex
    (append t_const
            (list (cons 1
                        (rtos (vlax-curve-getDistAtPoint
                                graf
                                (vlax-curve-getClosestPointTo
                                  graf
                                  (vlax-safearray->list per)))
                              2
                              2))
                  (list 10 (car begin) ins_pt 0.0))))
  (setq begin (list (+ step (car begin)) (cadr begin)))
  ) ;end of while

[skkkk]

Сообщение от P_S По-моему, что-то вы перемудрили

Вообще-то - да. Хотя, я бы сказал, "недомудрил". Вообще ничего не продумывал особо. Поэтому и сразу назвал команду "TEST". Полилинию, конечно, можно не разбивать. Просто в файле с исходной задачей она была уже разорванна в клочья. Я подумал, что это результат работы какой-то программы, поэтому не стал вдаваться в подробности и сделал применительно к файлу-задаче. К тому моменту, как я прочитал (что надо еще и разрывать), добрая часть кода уже родилась Поэтому я переделывать уже не стал - время свободное вышло, просто дал ссылку на "разбивалку".
Я подумал вот что. Надо дать Рyslan'у немного поработать "в бою", может, он еще что выявит. И в случае необходимости, чтобы код стал действительно рабочим, надо будет чуток доработать его с учетом:
1. Не бить линию на куски.
2. Добавить проверку направления обхода вершин.
3. Добавить обработку плавающей точки. Вот тут момент спорный. Если сделать, чтобы результат обработки линий по частям (за два-три захода со вводом вместо нуля предыдущего значения) совпадал с результатом обработки цельной полилинии, то в итоге конечная цифра будет до нескольких десятых метра расходится с длиной линии в свойствах. Даже и не знаю, как тут правильно поступить. Может, разумнее будет вводить стартовую длину до трех знаков после запятой? Или запрашивать не число, а линию и брать длину с нее?
Вопрос еще в том, насколько эта программа перейдет в разряд необходимых, может, это просто разовая (двух-) задача?

----- добавлено через 58 сек. -----
P.S.: P_S, кстати, у Вас теряется последний текст.

[Рyslan]

Всем привет! Спасибо за помощь! Я полилинию разбивал, чтобы через свойства посчитать длину. Но если можно будет не разбивая посчитать, то это вообще шикарно! skkkk я результаты подсчета после твоей программы не проверял )))) надеюсь там все ок ))))

[P_S]

Да, выход из цикла у меня получился с ошибкой (safearray с нулевым значением не есть nil), так что корректно получается что-то такое:

Код:

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

 (defun C:TEST  (/ graf step ins_pt m_sp t_const begin per)
  (princ "\nУкажите линию рельефа")
  (setq graf    (vlax-ename->vla-object
                  (ssname (ssget "_:S" '((0 . "LWPOLYLINE"))) 0))
        step    (getint "Введите шаг:  ")
        ins_pt  (cadr (getpoint "\nУкажите Y-координату начала строк: "))
        m_sp    (vla-get-ModelSpace
                  (vla-get-ActiveDocument (vlax-get-acad-object)))
        t_const (append
                  '((0 . "TEXT")
                    (100 . "AcDbEntity")
                    (67 . 0)
                    (410 . "Model")
                    (100 . "AcDbText")
                    (50 . 1.5708))
                  (list (cons 40 (getreal "\nВведите высоту текста:  ")))
                  '((41 . 1.0)
                    (51 . 0.0)
                    (7 . "Standard")
                    (71 . 0)
                    (72 . 0)));DXF-коды, общие для всех текстовых меток
        begin   (vlax-curve-getStartPoint graf)
        )
  (entmakex (append t_const
                    (list (cons 1 "0.00")
                          (list 10 (car begin) ins_pt 0.0))))
  (setq begin (list (+ step (car begin)) (cadr begin)))
  (repeat (fix (/ (- (car (vlax-curve-getEndPoint graf))
                     (car (vlax-curve-getStartPoint graf)))
                  step))
    (setq per
           (vlax-safearray->list
             (vlax-variant-value
               (vla-IntersectWith
                 graf
                 (vla-AddLightWeightPolyline
                   m_sp
                   (vlax-safearray-fill
                     (vlax-make-safearray vlax-vbDouble '(0 . 3))
                     (list (car begin)
                           (- (cadr begin) 1000)
                           (car begin)
                           (+ (cadr begin) 1000))))
                 acExtendOtherEntity))))
    (entdel (entlast))
    (entmakex
      (append t_const
              (list (cons 1
                          (rtos (vlax-curve-getDistAtPoint
                                  graf
                                  (vlax-curve-getClosestPointTo
                                    graf
                                    per))
                                2
                                2))
                    (list 10 (car begin) ins_pt 0.0))))
    (setq begin (list (+ step (car begin)) (cadr begin)))
    ) ;end of repeat

  (entmakex
    (append
      t_const
      (list (cons 1 (rtos (vla-get-Length graf) 2 2))
            (list 10 (car (vlax-curve-getEndPoint graf)) ins_pt 0.0))))
  )

[skkkk]

Сообщение от Рyslan результаты подсчета после твоей программы не проверял

В том файле, на котором я делал, было все ОК. Это я имел в виду, что вдруг на других рабочих файлах какая из полилиний как-то "обратилась" к лесу задом. Хотя, если начальная была слева направо, то и результирующие куски будут такими же.
Вообще, конечно, я считаю, надежнее будет использовать алгоритм от P_S. Даже если не уследил за направлением полилинии, косяк незамеченным точно не останется - ноль справа будет. Единственное, что я еще заметил, что тексты там расставляются не строго по центру каждый над своей линией, а со смещением влево на пол высоты текста. Выравнивание у текстов - слева вверх. Если, это, конечно, важно.

[Рyslan]

P_S, skkkk Привет! Спасибо, последнюю программу посмотрел, все работает. Вопрос, а если полилиния (рельеф) разбит не на равные участки, шаг текста не получится задать одной цифрой. Можно сделать чтобы текст выставлялся над точками полилинии (без ввода шага)?

[Кулик Алексей aka kpblc]

А, может, все же в отдельную тему?

[Рyslan]

Как скажешь А что сделать то надо?

[Кулик Алексей aka kpblc]

Здесь уже ничего - не станешь же фильтровать посты...
А так - сумма длин кривых и расстановка текста разные задачи. Создай новую тему, задай там вопрос, упомяни, что "начало обсуждения там-то, создал отдельную тему по просьбе модератора" - и все будет хорошо.

[Рyslan]

Сообщение от Кулик Алексей aka kpblc А так - сумма длин кривых и расстановка текста разные задачи

Вообще-то этот текст и есть сумма длин кривых и программа та же. Чего плодить тему. Я думал ты хочешь эти программы вынести в другую тему. Типа "Подсчет расстояний в профиле по рельефу земли" для оформления подвала чертежа продольного профиля трубопровода

[Alex_Shaton]

Уважаемые гуру! Можно ли отредактировать код из поста 62, чтобы в чертеж вставлялась бы не округленное значение длины полилинии, а сумма значений длин сегментов, округленных до первого знака после запятой?

[Кулик Алексей aka kpblc]

Можно. Редактируй.

[skkkk]

Чем отличается сумма значений длин сегментов полилинии от ее общей длины?

[trir]

Чем отличается сумма значений длин сегментов полилинии от ее общей длины?

округлением

[Loolik]

Уважаемые форумчане, подскажите, как изменить ЛИСП из 104 сообщения, чтобы при выполнении он вписывал существующее значение переменной, а при нажатии на Enter принимал это же значение

Сообщение от VVA Код: [Выделить все] (defun c:MM ( / buf ) (initget 7) ;; Хочу получить переменную (setq *MIP-MODEMACRO-SCALE* (getreal "\nНовый масштабный коэффициент: ")) (initget 6) (princ "\nВысота текста <")(princ *MIP-MODEMACRO-HTXT*)(princ ">: ") (if (setq buf (getdist))(setq *MIP-MODEMACRO-HTXT* buf)) (initget 4 "L") (princ "\nТочность округления [Luprec] <") (if (< *MIP-MODEMACRO-RTOS* 0)(princ "Luprec")(princ *MIP-MODEMACRO-RTOS*)) (princ ">: ") (if (setq buf (getint))(setq *MIP-MODEMACRO-RTOS* (if (numberp buf) buf -1))) (VL-PROPAGATE '*MIP-MODEMACRO-HTXT*) (VL-PROPAGATE '*MIP-MODEMACRO-RTOS*) (VL-PROPAGATE '*MIP-MODEMACRO-SCALE*) (princ) )

Пытался сделать так, текущее значение получаю, но после нажатия Enter число не принимается, и приходится все равно вручную вбивать нужную цифру.

Код:

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

 
(defun c:MM ( / buf ) 
(initget 7)
;; Получаю переменную, но Enter не срабатывает
(setq *MIP-MODEMACRO-SCALE*  (getreal (strcat "\nТекущий масштабный коэффициент<" (rtos *MIP-MODEMACRO-SCALE* 2 2) ">: "))
(initget 6) 
(princ "\nВысота текста <")(princ *MIP-MODEMACRO-HTXT*)(princ ">: ") 
(if (setq buf (getdist))(setq *MIP-MODEMACRO-HTXT* buf)) 
(initget 4 "L")
(princ "\nТочность округления [Luprec] <") (if (< *MIP-MODEMACRO-RTOS* 0)(princ "Luprec")(princ *MIP-MODEMACRO-RTOS*)) (princ ">: ")
(if (setq buf (getint))(setq *MIP-MODEMACRO-RTOS* (if (numberp buf) buf -1)))
(VL-PROPAGATE '*MIP-MODEMACRO-HTXT*)
(VL-PROPAGATE '*MIP-MODEMACRO-RTOS*)
(VL-PROPAGATE '*MIP-MODEMACRO-SCALE*) 
(princ) 
)

[Sinmad]

GeomProps

[Loolik]

Сообщение от Sinmad GeomProps

О GeomProps конечно знаю, но хочу использовать в некоторых ситуациях ЛИСП.

[koMon]

Сообщение от Loolik чтобы при выполнении он вписывал существующее значение переменной, а при нажатии на Enter принимал это же значение

Код:

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

 
(initget 6)
;; Хочу получить переменную
(setq mmss t)
(while mmss 
	(setq *MIP-MODEMACRO-SCALE* (if (null (setq mms_temp (getreal (strcat "\nНовый масштабный коэффициент: <" (if *MIP-MODEMACRO-SCALE* (rtos *MIP-MODEMACRO-SCALE*) "") ">: ")))) 
									*MIP-MODEMACRO-SCALE*
									mms_temp
								)
		   mmss (if *MIP-MODEMACRO-SCALE* nil t)
	)
)

[Loolik]

Спасибо koMon, код работает!
Пытаюсь модифицировать ЛИСП из поста 104 и сделать две команды (но в идеале одну):

1. Len2NT - задаю пользовательский коэффициент пересчета |-> выделяю геометрию для вычисления длины |-> вставляю новый текст в чертеж.
   Эта фукция работает.
2. Len2ET - задаю пользовательский коэффициент пересчета |-> выделяю геометрию для вычисления длины |-> вставляю в существующий текст/ячейку таблицы в чертеж.
   Эта функция не работает для пустых ячеек таблиц.
3. Len2TX - В идеале хочется такую команду - задаю пользовательский коэффициент пересчета |-> выделяю геометрию для вычисления длины |-> выбираю режим вставки результата (либо новый текст, либо изменить существующий).

Прошу помощи, как допилить код, чтобы результат вставлялся в пустую ячейку таблицы? При копипасте кода функции TTC_Paste из поста 162, работать программа отказалась.
Если есть возможность помогите с "однокомандной хотелкой" Len2TX .

Код:

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

 
(vl-load-com)
(if (null *MIP-MODEMACRO-HTXT*)
  (setq *MIP-MODEMACRO-HTXT* 300)
  ) ;_Высота текста
(if (null *MIP-MODEMACRO-RTOS*)
  (setq *MIP-MODEMACRO-RTOS* -1.0)
  ) ;_Округление -1-LUPREC
(if (null *MIP-MODEMACRO-SCALE*)
  (setq *MIP-MODEMACRO-SCALE* 1)
  ) ;_Масштаб
(vl-propagate '*MIP-MODEMACRO-HTXT*)
(vl-propagate '*MIP-MODEMACRO-RTOS*)
(vl-propagate '*MIP-MODEMACRO-SCALE*)
(defun C:entLen	 (/ set:entities int:allEntities int:curveEntities int:l rea:length)
  (princ "\nТекущий коэффициент K=")
  (princ (vl-princ-to-string *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst)))) ; Этот if добавлен для 
    (setq set:entities (ssget)) ; обработки предварительного 
    ) ;_ if                  ; выбора примитивов 
  (if set:entities
    (progn
      (setq int:allEntities
	     (sslength set:entities) ; количество выбранных примитивов 
	    int:curveEntities
	     0 ; счетчик линейных примитивов 
	    int:l 0 ; счетчик 
	    rea:length
	     0.0 ; общая длина линейных примитивов 
	    ) ;_  setq 
      (while (< int:l (sslength set:entities))
	(if
	  (not
	    (vl-catch-all-error-p
	      (vl-catch-all-apply
		'vlax-curve-getstartpoint
		(list
		  (vlax-ename->vla-object (ssname set:entities int:l))
		  ) ;_ list 
		) ;_  vl-catch-all-apply 
	      ) ;_  vl-catch-all-error-p 
	    ) ;_  not 
	   (setq int:curveEntities (1+ int:curveEntities)
		 rea:length	   (+ rea:length
				      (vlax-curve-getdistatparam
					(vlax-ename->vla-object
					  (ssname set:entities int:l)
					  ) ;_ vlax-ename->vla-object 
					(vlax-curve-getendparam
					  (ssname set:entities int:l)
					  ) ;_ vlax-curve-getEndParam 
					) ;_  vlax-curve-getDistAtParam 
				      ) ;_  + 
		 ) ;_  setq 
	   ) ;_  if 
	(setq int:l (1+ int:l))
	) ;_  while
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (princ (strcat "\n Выбрано примитивов: "
		     (itoa int:allEntities)
		     ", из них линейных: "
		     (itoa int:curveEntities)
		     "\nПоправочный коэфиициент K="
		     (rtos *MIP-MODEMACRO-SCALE* 2 2)
		     "\n Общая длина линейных примитивов: "
		     (rtos *MIP-LENGTH*
			   2
			   (if (< *MIP-MODEMACRO-RTOS* 0)
			     (getvar "LUPREC")
			     *MIP-MODEMACRO-RTOS*
			     ) ;_ конец if
			   ) ;_ конец rtos
		     ) ;_ strcat 
	     ) ;_ princ 
      ) ;_  progn 
    (alert "Примитивы не выбраны!")
    ) ;_  if 
  (prin1)
 ) ;_ конец defun entLen
  

(defun c:MM  (/ buf)
  (initget 7)
  (setq *MIP-MODEMACRO-SCALE* (getreal "\nНовый масштабный коэффициент: "))
  (initget 6)
  (princ "\nВысота текста <")
  (princ *MIP-MODEMACRO-HTXT*)
  (princ ">: ")
  (if (setq buf (getdist))
    (setq *MIP-MODEMACRO-HTXT* buf)
    ) ;_ конец if
  (initget 4 "L")
  (princ "\nТочность округления [Luprec] <")
  (if (< *MIP-MODEMACRO-RTOS* 0)
    (princ "Luprec")
    (princ *MIP-MODEMACRO-RTOS*)
    ) ;_ конец if
  (princ ">: ")
  (if (setq buf (getint))
    (setq *MIP-MODEMACRO-RTOS*
	   (if (numberp buf)
	     buf
	     -1
	     ) ;_ конец if
	  ) ;_ конец setq
    ) ;_ конец if
  (vl-propagate '*MIP-MODEMACRO-HTXT*)
  (vl-propagate '*MIP-MODEMACRO-RTOS*)
  (vl-propagate '*MIP-MODEMACRO-SCALE*)
  (princ)
) ;_ конец defun MM

(defun TTC_Paste(pasteStr keepText / nslLst vlaObj )
(if (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки <выход>: "))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE


;;Length Print to Existing text
(defun c:LPE ( )
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." ","  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 nil))
(princ)
) ;_ конец defun LPE
  

;;Length Print to New text
(defun c:LPN  ()
  (if (= (type *MIP-LENGTH*) 'REAL)
    (progn
      (vla-addtext
	(vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
	(vl-string-translate
	  "."
	  ","
	  (rtos	*MIP-LENGTH*
		2
		(if (< *MIP-MODEMACRO-RTOS* 0)
		  (getvar "LUPREC")
		  *MIP-MODEMACRO-RTOS*
		  ) ;_ конец if
		) ;_ конец rtos
	  ) ;_ конец vl-string-translate
	(vlax-3d-point '(0 0 0))
	*MIP-MODEMACRO-HTXT*
	) ;_ конец vla-addtext
      (princ "\n Укажите точку вставки текста:")
      (command "_.copybase" '(0 0 0) (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause)
      ) ;_ конец progn
    ) ;_ конец if
  (princ)
  ) ;_ конец defun
;;(princ "\nНаберите в командной строке:
;;          \nEntLen - подсчет примитивов
;;          \nMM - масштабный коэффициент и настройка
;;          \nLPN - результат в новый текст
;;          \nLPE - результат в существующий текст")
;;(princ)

;;Команда вставки нового текста с результатом вычислений суммы примитивов
;;с преварительным указанием масштабного коэффициента

(defun c:Len2NT	 ()
  (initget 6)
  (setq mmss t)
  (while mmss
    (setq *MIP-MODEMACRO-SCALE*
	   (if (null (setq mms_temp (getreal (strcat "\nНовый масштабный коэффициент: <"
						     (if *MIP-MODEMACRO-SCALE*
						       (rtos *MIP-MODEMACRO-SCALE*)
						       ""
						       ) ;_ конец if
						     ">: "
						     ) ;_ конец strcat
					     ) ;_ конец getreal
			   ) ;_ конец setq
		     ) ;_ конец null
	     *MIP-MODEMACRO-SCALE*
	     mms_temp
	     ) ;_ конец if
	  mmss (if *MIP-MODEMACRO-SCALE*
		 nil
		 t
		 ) ;_ конец if
	  ) ;_ конец setq
    ) ;_ конец while
  (C:ENTLEN)
  (C:LPN)
  ) ;_ конец defun Len2NT
  
;;Команда вставки в существующий текст результата вычислений суммы примитивов
;;с преварительным указанием масштабного коэффициента
(defun c:Len2ET	 ()
  (initget 6)
  (setq mmss t)
  (while mmss
    (setq *MIP-MODEMACRO-SCALE*
	   (if (null (setq mms_temp (getreal (strcat "\nНовый масштабный коэффициент: <"
						     (if *MIP-MODEMACRO-SCALE*
						       (rtos *MIP-MODEMACRO-SCALE*)
						       ""
						       ) ;_ конец if
						     ">: "
						     ) ;_ конец strcat
					     ) ;_ конец getreal
			   ) ;_ конец setq
		     ) ;_ конец null
	     *MIP-MODEMACRO-SCALE*
	     mms_temp
	     ) ;_ конец if
	  mmss (if *MIP-MODEMACRO-SCALE*
		 nil
		 t
		 ) ;_ конец if
	  ) ;_ конец setq
    ) ;_ конец while
  (C:ENTLEN)
  (C:LPE)
  ) ;_ конец defun Len2ET

[koMon]

Loolik, если коротенько обобщить, то длину каких примитивов нужно считать и в какие вставлять? По мне, так лучше выстругать новые грабли)

[Loolik]

koMon, постараюсь перефразировать)
Собственно, взят код из поста 104.
Добавляю в конце команду:
Len2ET - вставка результата функции EntLen в существующий Текст/МТекст/Ячейку таблицы/Атрибут/МВыноску. Эта команда работает как положено, за исключением вставки текста в ячейку таблицы с пустым текстом. Своими силами исправить ошибку не смогу

Код:

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

 
;;Команда вставки в существующий текст результата вычислений суммы примитивов
;;с преварительным указанием масштабного коэффициента
(defun c:Len2ET	 ()
  (initget 6)
  (setq mmss t)
  (while mmss
    (setq *MIP-MODEMACRO-SCALE*
	   (if (null (setq mms_temp (getreal (strcat "\nНовый масштабный коэффициент: <"
						     (if *MIP-MODEMACRO-SCALE*
						       (rtos *MIP-MODEMACRO-SCALE*)
						       ""
						       ) ;_ конец if
						     ">: "
						     ) ;_ конец strcat
					     ) ;_ конец getreal
			   ) ;_ конец setq
		     ) ;_ конец null
	     *MIP-MODEMACRO-SCALE*
	     mms_temp
	     ) ;_ конец if
	  mmss (if *MIP-MODEMACRO-SCALE*
		 nil
		 t
		 ) ;_ конец if
	  ) ;_ конец setq
    ) ;_ конец while
  (C:ENTLEN)
  (C:LPE)
  ) ;_ конец defun Len2ET

Интуитивно понимаю, что не работает эта часть кода

Код:

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

 
(defun TTC_Paste(pasteStr keepText / nslLst vlaObj )
(if (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки <выход>: "))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE


;;Length Print to Existing text
(defun c:LPE ( )
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." ","  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 nil))
(princ)
) ;_ конец defun LPE
  

[koMon]

Вот. Вы Entlen-ом суммарную длину каких-то определённых примитивов считаете, ну там отрезок, полилиния..? Потому как Entlen из #104, по ходу, будет считать всё, что считается.

[Loolik]

Сообщение от koMon Потому как Entlen из #104, по ходу, будет считать всё, что считается.

Именно это и нужно - считать всю возможную геометрию (полилинии, сплайны, дуги, отрезки, окружности). Чертежи могут оказаться чужими, а разбираться какими примитивами вычерчено не очень хочется.

[VVA]

Сообщение от Loolik Интуитивно понимаю, что не работает эта часть кода

Добавлена опция "Точка"

Код:

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

(defun TTC_Paste(pasteStr keepText / nslLst vlaObj tstyle txt pt tblobj lst tblset row col )
 ;;; keepText - t  -  сохранить текст
 ;;;         - nil - заменить текст
 ;;;         - "Точка" - вставить в ячейку таблицы
(if (eq keepText  "Точка")(setq nslLst keepText keepText nil))
(or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
(initget "Точка")
(if (or (eq nslLst "Точка")
        (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки [Точка для пустой ячейки] <выход>: "))
        )
(progn (cond
((eq nslLst "Точка")
 (setvar "cmdecho" 0)
(setq tstyle (getvar "TEXTSTYLE")) ;_Стиль текста Стиль должен существовать
    ;_ Создаем текст
(if (= (cdr (assoc 40 (tblsearch "STYLE" tstyle))) 0.0)
     ;; нулевая высота текста
   (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) *TEXTSIZE* 0 pasteStr)
   (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) 0 pasteStr)
   ) ;_ end of if
    (setq txt (entlast))
  ;_ Копируем в буфер и обратно
  (vl-cmdf "_updatefield" txt "")
  (princ "\n Укажите точку вставки текста или ячейку таблицы:")
  (vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
  ;_ В txt примитив текста в pt точка вставки  
  (setq txt (entlast) pt (getvar "LASTPOINT"))
(or
    (and ;_Проверяем, попала ли точка в ячейку таблицы
      (setq  tblobj nil tblset (ssget "_X" (list '(0 . "ACAD_TABLE")(cons 410 (getvar "CTAB")))))
      (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
      (progn
        (vl-catch-all-apply '(lambda()
        (mapcar '(lambda (x)
           (or tblobj
               (and
                 (= :vlax-true (vla-HitTest x
                               (vlax-3d-point (trans pt 1 0))
                               (vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
                               'row 'col))
                 (setq tblobj x)
                 )
               )
           )
        lst)
                               )
          )
        tblobj
        )
       row col
      (or (vla-SetText tblobj row col pasteStr) t)
      (entdel txt)
      )
    (and ;_Не попала, рисуем текст с полем
      (setq txt (vlax-ename->vla-object txt))
      (vlax-write-enabled-p txt)
      (vlax-method-applicable-p txt 'FieldCode) ;_есть метод FieldCode
      (vlax-property-available-p txt 'TextString)
      (vlax-put txt 'TextString pasteStr)
      )
    )
  )         
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF" "MULTILEADER"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4

(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE

[Loolik]

Сообщение от VVA Добавлена опция "Точка"

Спасибо, но результат выполнения "Точка для пустой ячейки" создает новый текстовый примитив.
А возможно реализовать вставку текста именно в пустую ячейку таблицы, причем без дополнительного выбора в контекстном меню? Т.е. чтобы TTC_Paste понимала, что я выбрал либо текстосодержащий объект (МТекст, Текст, Артибут, ЯчейкуТаблицыСТекстом), либо ПустуюЯчейкуТаблицы?

[VVA]

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

Сообщение от Loolik Точка для пустой ячейки" создает новый текстовый примитив

Ну так и ткни им в пустую ячейку и посмотри на результат

[Loolik]

Сообщение от VVA Ну так и ткни им в пустую ячейку и посмотри на результат

Происходит создание текста поверх таблицы. В содержимое ячейки ничего не вписывается. Проверял на AutoCAD 2009x86, AutoCAD 2015x64.

[VVA]

Сообщение от Loolik Происходит создание текста поверх таблицы.

Исправил #205

[Loolik]

VVA, спасибо за помощь, работает отлично.
Осталась последняя хотелка, но затыкаюсь в одном месте.
Программингом не владею, делаю свою команду по подобию, которая будет делать следующее:

1. Задаю пользовательский масштабный коэффициент
2. Выполняю подсчет длин примитивов
3. Указываю на выбор режим вставки результата /Новый текст/Существующий текст/Пустая ячейка таблицы/

Так вот затык получается при попытке выполнить вставку в пустую ячейку

Код:

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

(COMMAND (c:LPE) "_Точка")

Код:

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

(defun c:Len2TX1 (/ *ans* )
   ;; Задаем пользовательский масштабный коэффициент:
   (initget 6)
   (setq mmss t)
   (while mmss
      (setq *MIP-MODEMACRO-SCALE*
         (if (null 
               (setq mms_temp 
                  (getreal
                     (strcat "\nНовый масштабный коэффициент: <"
                        (if *MIP-MODEMACRO-SCALE* (rtos *MIP-MODEMACRO-SCALE*) "") ;_ конец if
                        ">: "
                     ) ;_ конец strcat
                  ) ;_ конец getreal
               ) ;_ конец setq
            ) ;_ конец null
            *MIP-MODEMACRO-SCALE* mms_temp
         ) ;_ конец if
         mmss (if *MIP-MODEMACRO-SCALE* nil t) ;_ конец if
      ) ;_ конец setq
   ) ;_ конец while
   ;; Выполняем подсчет длин примитивов
   (C:ENTLEN)
   ;; Определяем тип вставки результата
   (initget "Новый Существующий ПустЯчейкаТаблицы")
   (setq *ans*
      (cond
        (
          (getkword
            (strcat "\nРезультат в /Новый Текст/Существующий Текст/Пустую Ячейку Таблицы/ [Новый/Существующий/ПустЯчейкаТаблицы]<"
              (setq *ans*
                (cond ( *ans* ) ( "Новый" ))
              ) ">: "
            )
          )
        )
      )
    )
    (if (= *ans* "Новый") (c:LPN)
        (if (= *ans* "Существующий") (c:LPE) 
            (COMMAND (c:LPE) "_Точка")
        )
    )
) ; конец defun c:Len2TX1

[VVA]

Loolik, Так не пойдет. Я обновил #205 еще раз. Добавил возможность передать параметр "Точка" (почитай коментарии в начале)
Соответственно для вставки в ячейку таблицы своя команда

Код:

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

;;Length Print to Table sell
(defun c:LPT ( )
(and (= (type *MIP-LENGTH*) 'REAL)
(TTC_Paste (vl-string-translate "." ","  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
 "Точка"))
(princ))

[Loolik]

Сообщение от VVA Я обновил #205 еще раз. Добавил возможность передать параметр "Точка" (почитай коментарии в начале) Соответственно для вставки в ячейку таблицы своя команда

Огромное спасибо за помощь, все работает отлично! А вставка в МВыноску по умолчанию не предусмотрена? В принципе, это мне и не требуется.
Вдруг кому пригодится результат - запускать командой LEN2TX

Код:

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

(vl-load-com)
;;Задание глобальных переменных с параметрами вставки текста
(if (null *MIP-MODEMACRO-HTXT*) (setq *MIP-MODEMACRO-HTXT* 300)) ;_Высота текста 300 единиц
(if (null *MIP-MODEMACRO-RTOS*) (setq *MIP-MODEMACRO-RTOS* -1.0)) ;_Округление -1-LUPREC
(if (null *MIP-MODEMACRO-SCALE*) (setq *MIP-MODEMACRO-SCALE* 1)) ;_Масштабный коэффициент 1
(vl-propagate '*MIP-MODEMACRO-HTXT*)
(vl-propagate '*MIP-MODEMACRO-RTOS*)
(vl-propagate '*MIP-MODEMACRO-SCALE*)
(defun C:entLen (/ set:entities int:allEntities int:curveEntities int:l rea:length)
  (princ "\nТекущий коэффициент K=")
  (princ (vl-princ-to-string *MIP-MODEMACRO-SCALE*))
  (if (not (setq set:entities (cadr (ssgetfirst)))) ; Этот if добавлен для 
    (setq set:entities (ssget)) ; обработки предварительного 
  ) ;_ if                  ; выбора примитивов 
  (if set:entities
    (progn
      (setq 
        int:allEntities (sslength set:entities) ; количество выбранных примитивов 
        int:curveEntities 0 ; счетчик линейных примитивов 
        int:l 0 ; счетчик 
        rea:length 0.0 ; общая длина линейных примитивов 
      ) ;_  setq 
      (while (< int:l (sslength set:entities))
        (if
          (not
            (vl-catch-all-error-p
              (vl-catch-all-apply 'vlax-curve-getstartpoint
                (list
                  (vlax-ename->vla-object (ssname set:entities int:l))
                ) ;_ list 
              ) ;_  vl-catch-all-apply 
            ) ;_  vl-catch-all-error-p 
          ) ;_  not 
          (setq int:curveEntities (1+ int:curveEntities)
            rea:length (+ rea:length (vlax-curve-getdistatparam 
                                       (vlax-ename->vla-object (ssname set:entities int:l))
                                       (vlax-curve-getendparam (ssname set:entities int:l)))) ;_  + 
          ) ;_  конец setq 
        ) ;_  конец if
        (setq int:l (1+ int:l))
      ) ; конец  while
      (setq *MIP-LENGTH* (* *MIP-MODEMACRO-SCALE* rea:length))
      (princ 
        (strcat "\n Выбрано примитивов: "
          (itoa int:allEntities) 
          ", из них линейных: "
          (itoa int:curveEntities)
          "\nПоправочный коэфиициент K="
          (rtos *MIP-MODEMACRO-SCALE* 2 2)
          "\n Общая длина линейных примитивов: "
          (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0) (getvar "LUPREC") *MIP-MODEMACRO-RTOS*) ;_ конец if
           ) ;_ конец rtos
        ) ;_ конец strcat 
      ) ;_ princ 
    ) ;_  progn 
    (alert "Примитивы не выбраны! Будет использован последний результат")
  ) ;_  if 
  (prin1)
) ;_ конец defun entLen


;;Задание глобальных переменных 
(defun c:MM  (/ buf)
  ;;Масштабный коэффициент
  (initget 7)
  (setq *MIP-MODEMACRO-SCALE* (getreal "\nНовый масштабный коэффициент: "))
  ;;Высота текста
  (initget 6)
  (princ "\nВысота текста <")
  (princ *MIP-MODEMACRO-HTXT*)
  (princ ">: ")
  (if (setq buf (getdist))
    (setq *MIP-MODEMACRO-HTXT* buf)
  ) ;_ конец if
  ;;Точность округления
  (initget 4 "L")
  (princ "\nТочность округления [Luprec] <")
  (if (< *MIP-MODEMACRO-RTOS* 0)
    (princ "Luprec")
    (princ *MIP-MODEMACRO-RTOS*)
  ) ;_ конец if
  (princ ">: ")
  (if (setq buf (getint))
    (setq *MIP-MODEMACRO-RTOS*
      (if (numberp buf)
        buf
        -1
      ) ;_ конец if
    ) ;_ конец setq
  ) ;_ конец if
  (vl-propagate '*MIP-MODEMACRO-HTXT*)
  (vl-propagate '*MIP-MODEMACRO-RTOS*)
  (vl-propagate '*MIP-MODEMACRO-SCALE*)
  (princ)
) ;_ конец defun MM

;;Вставка результата в текст или таблицу
(defun TTC_Paste (pasteStr keepText / nslLst vlaObj tstyle txt pt tblobj lst tblset row col )
;; keepText - t  -  сохранить текст
;;         - nil - заменить текст
;;         - "Точка" - вставить в ячейку таблицы
  (if (eq keepText  "Точка")
    (setq nslLst keepText keepText nil)
  );_ конец if
  (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
  (initget "Точка")
  (if 
    (or (eq nslLst "Точка")
      (setq nslLst(nentsel "\nТекст, атрибут, таблица или размер для вставки [Точка для пустой ячейки] <выход>: "))
    )
    (progn 
      (cond
      ;  start condition #1
        (
          (eq nslLst "Точка")
          (setvar "cmdecho" 0)
          (setq tstyle (getvar "TEXTSTYLE")) ;_Стиль текста Стиль должен существовать
          ;_ Создаем текст
          (if (= (cdr (assoc 40 (tblsearch "STYLE" tstyle))) 0.0)
            ;; нулевая высота текста
            (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) *TEXTSIZE* 0 pasteStr)
            (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) 0 pasteStr)
          ) ;_ end of if
          (setq txt (entlast))
          ;_ Копируем в буфер и обратно
          (vl-cmdf "_updatefield" txt "")
          (princ "\n Укажите точку вставки текста или ячейку таблицы:")
          (vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
          ;_ В txt примитив текста в pt точка вставки  
          (setq txt (entlast) pt (getvar "LASTPOINT"))
          (or
            (and ;_Проверяем, попала ли точка в ячейку таблицы
              (setq  tblobj nil tblset (ssget "_X" (list '(0 . "ACAD_TABLE")(cons 410 (getvar "CTAB")))))
              (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
              (progn
                (vl-catch-all-apply 
                  '(lambda()
                    (mapcar 
                      '(lambda (x)
                        (or tblobj
                          (and
                            (= :vlax-true 
                              (vla-HitTest x
                                (vlax-3d-point (trans pt 1 0))
                                (vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
                                'row 'col
                              )
                            )
                            (setq tblobj x)
                          )
                        )
                      )
                      lst
                    )
                  )
                )
                tblobj
              ) ; end progn
              row col
              (or (vla-SetText tblobj row col pasteStr) t)
              (entdel txt)
            ) ; end and
            (and ;_Не попала, рисуем текст с полем
              (setq txt (vlax-ename->vla-object txt))
              (vlax-write-enabled-p txt)
              (vlax-method-applicable-p txt 'FieldCode) ;_есть метод FieldCode
              (vlax-property-available-p txt 'TextString)
              (vlax-put txt 'TextString pasteStr)
            ) ; end and
          ) ; end or
        ) ; end condition #1

        ; start condition #2
        (
          (and (= 4 (length nslLst))
            (= "DIMENSION" (cdr(assoc 0(entget(car(last nslLst))))))
          ); end and
          (setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
          (setq oldStat (vla-get-Measurement vlaObj))
          (if keepText
            (if (= (vla-get-TextOverride vlaObj) "")
            (setq pasteStr (strcat
              pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) 
              (vla-get-PrimaryUnitsPrecision vlaObj)))
            ) ; end setq
            (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj))))
          ) ; end if
          (if 
            (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
            (princ "\n Can't paste. Object may be on locked layer. ")
          ) ; end if
        ); end condition #2

        ; start condition #3
        (
          (and (= 4(length nslLst))
            (= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))
          ); end and
          (setq vlaObj (vlax-ename->vla-object(car nslLst)))
          (if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
          (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
            (princ "\nError. Can't pase text. ") (entupd (car(last nslLst)))
          ) ; end if
        ); end condition # 3

        ; start condition #4
        (
          (and (= 4(length nslLst))
            (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))
          ); end and
          (princ "\nCan't paste to block's DText or MText. ")
        ); end condition #4

        ; start condition #5
        (
          (and (= 2(length nslLst))
            (member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF" "MULTILEADER"))
          ); end and
          (setq vlaObj (vlax-ename->vla-object(car nslLst)))
          (if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
          (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
            (princ "\nError. Can't pase text. ")
          ) ; end if
        ); end condition #5

        ; start condition #6
        (T (princ "\nCan't paste. Invalid object. ")); end condition #6
      ); end cond
    T); end progn
  nil); end if
);_TTC_PASTE


;;Length Print to Existing text
(defun c:LPE ( )
  (and (= (type *MIP-LENGTH*) 'REAL)
    (TTC_Paste 
      (vl-string-translate "." "," 
        (rtos *MIP-LENGTH* 2
          (if (< *MIP-MODEMACRO-RTOS* 0)
            (getvar "LUPREC")
            *MIP-MODEMACRO-RTOS*
          )
        )
      )
      nil
    )
  )
  (princ)
) ;_ конец defun LPE
  

;;Length Print to New text
(defun c:LPN  ()
  (if (= (type *MIP-LENGTH*) 'REAL)
    (progn
      (vla-addtext
        (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
        (vl-string-translate "." "," 
          (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0) 
              (getvar "LUPREC") 
              *MIP-MODEMACRO-RTOS*
            ) ;_ конец if
          ) ;_ конец rtos
        ) ;_ конец vl-string-translate
       (vlax-3d-point '(0 0 0))
       *MIP-MODEMACRO-HTXT*
      ) ;_ конец vla-addtext
      (princ "\n Укажите точку вставки текста:")
      (command "_.copybase" '(0 0 0) (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause)
      ) ;_ конец progn
    ) ;_ конец if
  (princ)
) ;_ конец defun LPN


;;Length Print to Table sell
(defun c:LPT ( )
  (and (= (type *MIP-LENGTH*) 'REAL)
    (TTC_Paste (vl-string-translate "." ","  (rtos *MIP-LENGTH* 2
            (if (< *MIP-MODEMACRO-RTOS* 0)(getvar "LUPREC") *MIP-MODEMACRO-RTOS*)))
    "Точка")
  )
  (princ)
) ;_ конец defun LPT


;;(princ "\nНаберите в командной строке:
;;          \nEntLen - подсчет примитивов
;;          \nMM - масштабный коэффициент и настройка
;;          \nLPN - результат в новый текст
;;          \nLPE - результат в существующий текст или заполненную ячейку
;;          \nLPT - результат в пустую ячейку таблицы")
;;(princ)

;;Команда вставки нового текста с результатом вычислений суммы примитивов
;;с преварительным указанием масштабного коэффициента и выбором формата конечного результата
;;либо | Новый текст | Cуществующий текст или заполненная ячейка таблицы | Пустая ячейка таблицы |
(defun c:Len2TX (/ *ans* )
   ;; Задаем пользовательский масштабный коэффициент:
   (initget 6)
   (setq mmss t)
   (while mmss
      (setq *MIP-MODEMACRO-SCALE*
         (if (null 
               (setq mms_temp 
                  (getreal
                     (strcat "\nНовый масштабный коэффициент: <"
                        (if *MIP-MODEMACRO-SCALE* (rtos *MIP-MODEMACRO-SCALE*) "") ;_ конец if
                        ">: "
                     ) ;_ конец strcat
                  ) ;_ конец getreal
               ) ;_ конец setq
            ) ;_ конец null
            *MIP-MODEMACRO-SCALE* mms_temp
         ) ;_ конец if
         mmss (if *MIP-MODEMACRO-SCALE* nil t) ;_ конец if
      ) ;_ конец setq
   ) ;_ конец while
   ;; Выполняем подсчет длин примитивов
   (C:ENTLEN)
   ;; Определяем тип вставки результата
   (initget "Новый Существующий ПустЯчейкаТаблицы")
   (setq *ans*
      (cond
        (
          (getkword
            (strcat "\nРезультат в |_Новый Текст_|_Существующий Текст_|_Пустую Ячейку Таблицы_|" "\n[Новый/Существующий/ПустЯчейкаТаблицы]<"
              (setq *ans*
                (cond ( *ans* ) ( "Новый" ))
              ) ">: "
            )
          )
        )
      )
    )
    (if (= *ans* "Новый") (c:LPN)
        (if (= *ans* "Существующий") (c:LPE) 
            (c:LPT)
        )
    )
) ; конец defun c:Len2TX

[VVA]

Сообщение от Loolik А вставка в МВыноску по умолчанию не предусмотрена

Когда писалась эта программа мультивыносок не было как класса. Обновил #205 Правки минимальные (добавить "MULTILEADER" в перечень)

(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF" "MULTILEADER"))); end and

[Loolik]

Спасибо!

Сообщение от VVA Обновил #205

Обновил #212

[koMon]

Loolik,
я-таки, в промежутках между, выстругал альтернативные к-рабли)...

[Loolik]

koMon, Спасибо огромное, очень добротная реализация с богатым функционалом! Не хватает лишь кнопки "Создать новый текст" на самый искушенный случай)

[koMon]

Сообщение от Loolik Не хватает лишь кнопки "Создать новый текст" на самый искушенный случай)

Для нового текста нужно кликнуть туда, где хочешь его создать, то есть нужно не зацепить то, во что можно вставить сумму)

[Loolik]

Тогда крайне удобные получились грабли) Спасибо!

[koMon]

Loolik,
Happy husing!-)
Хочу отметить, что проверок на заблокированность текущего слоя, слоёв объектов, выбранных для вставки суммы не производится, то есть вполне возможно аварийное завершение команды. Новый текст вставляется в кликнутую точку с в текущем слое с текущим стилем и высотой 5 единиц.

[Tyhig]

На мой взгляд это был самый лучший вариант от Mike - lisp для суммирования длин линий отрезков полилиний и т.п.
Сколько же вы тут написали...

Ключевые слова.
Макрос, длина линий, длина отрезков, длина полилиний, Lsum , Mike - lisp , tyhig (мой ник только ключевое слово для поиска).

Сообщение от ;14569 ;****************************************************************************** ; ; Lsum -функция определяет суммарные длинну и площадь набора линий и полилиний ; ;****************************************************************************** (defun C:lsum (/ cmdold nabor nl i j prima sum_line sum_pline asum_pline pt_list) (vl-load-com) (setq cmdold (getvar "cmdecho")) (setvar "cmdecho" 0) (princ "\n Выберите линии и 2D-полилинии:\n") (if (eq nil (setq nabor (ssget '((-4 . "<OR") (0 . "line") (0 . "lwpolyline") (-4 . "OR>") ) ) ) ) (progn (princ "***** Среди указаных объектов ни линий, ни 2D-полилиний НЕТ! *****\n")(textscr)(princ) ) (progn (setq nl (sslength nabor)) (setq i nl j 0 sum_line 0 sum_pline 0 asum_pline 0) (while (< 0 i) (setq i (1- i)) (setq prima (ssname nabor i)) (if (eq "LWPOLYLINE" (cdr (assoc 0 (entget prima)))) (progn (command "_AREA" "_o" (ssname nabor i)) (setq sum_pline (+ sum_pline (getvar "Perimeter"))) (if (or (eq 1 (cdr (assoc 70 (entget prima)))) (equal (assoc 10 (entget prima)) (assoc 10 (reverse (entget prima)))) ) (setq asum_pline (+ asum_pline (getvar "Area"))) ) ) (progn (setq sum_line (+ sum_line (vla-get-length (vlax-ename->vla-object prima)))) (setq pt_list (append pt_list (cdr (assoc 10 (entget prima))) (cdr (assoc 11 (entget prima))))) (setq j (1+ j)) ) ) ) (setvar "cmdecho" cmdold) (textscr) (princ " Выбрано: Линий - ")(princ j)(princ "; Полилиний - ")(princ (- nl j))(princ ".\n") (princ " Сумма длин линий - ")(princ sum_line)(princ "\n") (princ " Суммарный периметр полилиний - ")(princ sum_pline)(princ "\n") (princ " Сумма площадей \"замкнутых\" полилиний - ")(princ asum_pline)(princ "\n") (princ) ) ) ) (princ "\n Загружена утилита Lsum,\n") (princ " вычисляющая сумму длин линий и суммарный периметр полилиний,\n") (princ " для \"замкнутых\" полилиний вычисляется сумма площадей.\n") (princ " Для работы с утилитой введите в командной строке Lsum.\n") (textscr) (princ)

;******************************************************************************
;
; Lsum -функция определяет суммарные длинну и площадь набора линий и полилиний
;
;******************************************************************************
(defun C:lsum (/ cmdold nabor nl i j prima sum_line sum_pline asum_pline pt_list)
(vl-load-com)
(setq cmdold (getvar "cmdecho"))
(setvar "cmdecho" 0)
(princ "\n Выберите линии и 2D-полилинии:\n")
(if (eq nil (setq nabor (ssget '((-4 . "<OR")
(0 . "line")
(0 . "lwpolyline")
(-4 . "OR>")
) ) ) )
(progn
(princ "***** Среди указаных объектов ни линий, ни 2D-полилиний НЕТ! *****\n")(textscr)(princ)
)
(progn
(setq nl (sslength nabor))
(setq i nl j 0 sum_line 0 sum_pline 0 asum_pline 0)
(while (< 0 i)
(setq i (1- i))
(setq prima (ssname nabor i))
(if (eq "LWPOLYLINE" (cdr (assoc 0 (entget prima))))
(progn
(command "_AREA" "_o" (ssname nabor i))
(setq sum_pline (+ sum_pline (getvar "Perimeter")))
(if (or (eq 1 (cdr (assoc 70 (entget prima))))
(equal (assoc 10 (entget prima)) (assoc 10 (reverse (entget prima))))
)
(setq asum_pline (+ asum_pline (getvar "Area")))
)
)
(progn
(setq sum_line (+ sum_line (vla-get-length (vlax-ename->vla-object prima))))
(setq pt_list (append pt_list (cdr (assoc 10 (entget prima))) (cdr (assoc 11 (entget prima)))))
(setq j (1+ j))
)
)
)
(setvar "cmdecho" cmdold)
(textscr)
(princ " Выбрано: Линий - ")(princ j)(princ "; Полилиний - ")(princ (- nl j))(princ ".\n")
(princ " Сумма длин линий - ")(princ sum_line)(princ "\n")
(princ " Суммарный периметр полилиний - ")(princ sum_pline)(princ "\n")
(princ " Сумма площадей \"замкнутых\" полилиний - ")(princ asum_pline)(princ "\n")
(princ)
)
)
)




(princ "\n Загружена утилита Lsum,\n")
(princ " вычисляющая сумму длин линий и суммарный периметр полилиний,\n")
(princ " для \"замкнутых\" полилиний вычисляется сумма площадей.\n")
(princ " Для работы с утилитой введите в командной строке Lsum.\n")
(textscr)
(princ)