| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Нужен LISP для суммы длин отрезков линни

Нужен LISP для суммы длин отрезков линни

Ответ
Поиск в этой теме
Непрочитано 26.02.2004, 10:13
Нужен LISP для суммы длин отрезков линни
ilka_t
 
Москва
Регистрация: 20.01.2004
Сообщений: 154

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

Полилиния не подходит т.к. эти отрезки разбросаны по всему чертежу, а надобы выбрав несколько линий узнать их общую длинну.
Просмотров: 140317
 
Непрочитано 04.02.2005, 15:19
#41
Apelsinov

Проектировщик ВК. LISP-любитель.
 
Регистрация: 15.12.2003
Москва
Сообщений: 1,186
<phrase 1=


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

Код:
[Выделить все]
;;;******************************
;;;Apelsinov
;;;[email protected]
;;;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
;;;[email protected]
;;;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
Apelsinov вне форума  
 
Непрочитано 03.03.2005, 17:54
#42
kos

LISP-программист
 
Регистрация: 25.08.2003
Тутэйшы
Сообщений: 238


В свои коды функций на 1-ой и 2-ой страницах вставил
Код:
В связи с тем, что периодически возникают вопросы...
__________________
Там все есть для счастья - меня там только нет.
Так это значит, что я там - буду!
kos вне форума  
 
Непрочитано 05.03.2005, 13:11
#43
boker

Engineer
 
Регистрация: 01.03.2005
Israel
Сообщений: 7


Скажите плиз, что надо вводить чтоб заработал последний лисп тот что Apelsinov написал
что надо вводить в командную строку?
boker вне форума  
 
Непрочитано 05.03.2005, 13:36
#44
Torino


 
Регистрация: 21.08.2003
Штаб
Сообщений: 943
<phrase 1=


apel_perim
Torino вне форума  
 
Непрочитано 05.03.2005, 14:22
#45
boker

Engineer
 
Регистрация: 01.03.2005
Israel
Сообщений: 7


спасибо, получилось
boker вне форума  
 
Непрочитано 04.05.2005, 01:12
#46
{Smirnoff}

Инженер по системам безопасности
 
Регистрация: 23.11.2003
Рига
Сообщений: 1,099


Ну что еще попробуем? Все что было до этого к сожалениию не позволяло предварительно выбрать нужные примитивы с помощью 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)
{Smirnoff} вне форума  
 
Непрочитано 04.05.2005, 09:59
#47
MIP

инженер
 
Регистрация: 13.12.2004
Минск
Сообщений: 496


>>Fantomas
А мы поступили следующим образом, навесили на кнопку макрос
Код:
[Выделить все]
^C^C(if (null C:MIP_MIPEntLen)(mi_load "mip_all"));MIPEntLen;
и все работает как часики даже с предварительным выбором и фильтрами! Замечу только что имена команды и файла содержащего Лисп, нужно заменить на заложенные у Вас!
MIP вне форума  
 
Непрочитано 04.05.2005, 11:09
#48
Apelsinov

Проектировщик ВК. LISP-любитель.
 
Регистрация: 15.12.2003
Москва
Сообщений: 1,186
<phrase 1=


>Fantomas
На вскидку - для мультилинии c:elen выдаст ошибку ....
Apelsinov вне форума  
 
Непрочитано 04.05.2005, 11:48
#49
{Smirnoff}

Инженер по системам безопасности
 
Регистрация: 23.11.2003
Рига
Сообщений: 1,099


>Apelsinov
Спасибо исправил! Совсем забыл про мультилинию. С мультилинией вопрос сложный... Что мерять? Сумму длинн составляющих её линий или осевую линию как у тебя или самую длинную линию :?: Пока я её не включаю поскольку специалисты в разных областях могут получать некорректные результакты.
{Smirnoff} вне форума  
 
Непрочитано 04.05.2005, 18:36
#50
Apelsinov

Проектировщик ВК. LISP-любитель.
 
Регистрация: 15.12.2003
Москва
Сообщений: 1,186
<phrase 1=


Цитата:
Сообщение от Fantomas
Ну что еще попробуем? <...>
Еще вариант...
Для не посвященных: от предыдущего моего отличается присутствием предварительного выбора и, наверное, скоростью....может быть
А чем отличается от Фантомасовского непосвященным знать не судьба, разьве что среднюю линию для мульти считает, и еще хрень всякую...
Код:
[Выделить все]
;;;******************************
;;;Apelsinov
;;;[email protected]
;;;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
Apelsinov вне форума  
 
Непрочитано 05.05.2005, 13:23
#51
{Smirnoff}

Инженер по системам безопасности
 
Регистрация: 23.11.2003
Рига
Сообщений: 1,099


По поручению 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
Кто следующий :?:
{Smirnoff} вне форума  
 
Непрочитано 16.05.2005, 16:27
#52
Georg

Design
 
Регистрация: 27.10.2004
Kiev
Сообщений: 57


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

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

Код:
[Выделить все]
;;;Если необходима длина каждого примитива 
;;;              (apply 'strcat 
;;;                     (cons "\nДлина каждого примитива:" 
;;;                           (mapcar '(lambda (i) (strcat "\n" (rtos i))) 
;;;                                   (vl-remove nil nab) 
;;;                           ) 
;;;                     ) 
;;;              ) 
            )
пользуюсь, очень удобно
весь лисп на второй странице этой темы

можно прицепить такой же вагончик к подсчету площадей?
Georg вне форума  
 
Непрочитано 16.05.2005, 16:49
#53
{Smirnoff}

Инженер по системам безопасности
 
Регистрация: 23.11.2003
Рига
Сообщений: 1,099


>Georg

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

проектировщик ОВ и ТМ
 
Регистрация: 16.08.2005
Ростов-на-Дону
Сообщений: 106


Цитата:
Сообщение от Apelsinov
Цитата:
Сообщение от Fantomas
Ну что еще попробуем? <...>
Еще вариант...
Для не посвященных: от предыдущего моего отличается присутствием предварительного выбора и, наверное, скоростью....может быть
А чем отличается от Фантомасовского непосвященным знать не судьба, разьве что среднюю линию для мульти считает, и еще хрень всякую...
При выборе мультилинии в ACAD2006 выдает:
Select objects:
; error: no function definition: RU-GEOM-GET-PERIMETER


:?: :?:
__________________
Between...
Styx вне форума  
 
Непрочитано 16.09.2006, 14:51
#55
Karales


 
Регистрация: 17.05.2006
Сообщений: 11


Ищу LISP (и.т.п) для измерения длин труб(цилиндров) разных диаметров.
Karales вне форума  
 
Непрочитано 11.05.2007, 17:58 грузится, но не выполняется
#56
you_you


 
Регистрация: 11.05.2007
Одесса
Сообщений: 2


Работаю в 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)
)
Где искать причину?
you_you вне форума  
 
Непрочитано 11.05.2007, 21:17
#57
Мечтатель


 
Регистрация: 18.04.2007
Самара
Сообщений: 9


Простенько считает длину линий и выдает результат в командной строке, вдруг подойдет, (не хочу показаться навязчивым грузим 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)
)
Мечтатель вне форума  
 
Непрочитано 11.05.2007, 21:19
#58
Мечтатель


 
Регистрация: 18.04.2007
Самара
Сообщений: 9


чет не доглядел страницы до конца, постыдился бы выкладывать
Мечтатель вне форума  
 
Непрочитано 12.05.2007, 08:11
#59
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,772


> 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.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 14.05.2007, 11:38
#60
you_you


 
Регистрация: 11.05.2007
Одесса
Сообщений: 2


> Кулик Алексей aka kpblc
Спасибо, помогло.
you_you вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Нужен LISP для суммы длин отрезков линни

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск