Добавление в чертеж длины полилинии

Кочетков Андрей · 01.08.2007, 11:25

Господа программисты, нужна ваша помощь.

Мне нужна программа которая делает следующее:

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

Попытался сам сделать, но на создании текста застопорился, а на эксперименты нет времени.

Кулик Алексей aka kpblc · 01.08.2007, 11:28

_.field :?:

Кочетков Андрей · 01.08.2007, 12:15

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

(defun c

llenins ()
(setq len (vla-get-length (vlax-ename->vla-object (car (entsel)))))

Кулик Алексей aka kpblc · 01.08.2007, 12:26

Хорошо

Тебе программно создавать просто тексты или филды надо?

VVA · 01.08.2007, 12:30

>Кочетков Андрей
Какая проблема быстренько пробежаться field'ми.

Код:

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

;_PolyLine Lenngth
;_http://forum.dwg.ru/showthread.php?p=156824#post156824
(defun C:PLL (/ en fld pt txt)
  (vl-load-com)
  (and
    (setq en (car (entsel "\nУкажите полилинию")))
    (wcmatch (cdr (assoc 0 (entget en))) "*POLYLINE")
    (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Length \\f \"%lu2%pr2\">%"
                ) ;_ strcat
          ) ;_ setq
    (or (initget 1) t)
    (setq pt (getpoint "\nУкажи точку текста: "))
    (setq pt (trans pt 1 0))
    (setq txt (entmakex
      (list
        (cons 0 "TEXT")
        (cons 100 "AcDbEntity")
        (cons 100 "AcDbText")
        (cons 72 0)           ;_ выравнивание влево
        (cons 1 fld)
        ;(cons 7 style) ;_Текущий стиль
        ;(cons 8 layer) ;_Текущий слой
        (cons 10 pt)
        (cons 11 pt)
        (cons 40 (getvar "TEXTSIZE")) ;_Текущей высотой текста
        ) ;_ list
      ) ;_ entmakex
          )
    ) ;_ and
  (vl-cmdf "_updatefield" txt "")
  (princ)
  ) ;_endof defun

Олег К. · 01.08.2007, 12:31

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

PS: могу попробовать, но быстро не обещаю.

PPS: а, пожоже не у меня одного обед. Пока читал и отвечал уже и прог накидали.

VVA · 01.08.2007, 12:31

Точнось правь в этом куске

Код:

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

(setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Length \\f \"%lu2%pr2\">%"
                ) ;_ strcat
          ) ;_ setq

pr2 - 2 знака после запятой
pr3 - 3 знака после запятой

Кочетков Андрей · 01.08.2007, 12:38

Я вас всех люблю

Спасибо

Володь, а можно добавить в обработку LINE и LWPOLYLINE ?

Кулик Алексей aka kpblc · 01.08.2007, 12:47

Те же яйца, только в профиль:

Код:

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

(defun c:flen1 (/ adoc ent pt *error*)
               ;|
*    Вставка полем с последовательным выбором полилиний "по одной"
|;
  (defun loc:unhighlight (ent)
    (vl-catch-all-apply
      '(lambda ()
         (if ent
           (vla-highlight
             (cond
               ((= (type ent) 'ename) (vlax-ename->vla-object ent))
               (t ent)
               ) ;_ end of cond
             :vlax-false
             ) ;_ end of vla-highlight
           ) ;_ end of if
         ) ;_ end of lambda
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of defun

  (defun *error* (msg)
    (loc:unhighlight ent)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (while
    (and
      (not (vl-catch-all-error-p
             (vl-catch-all-apply
               '(lambda ()
                  (setq ent (car (entsel "\nУкажите полилинию <Отмена> : ")))
                  ) ;_ end of lambda
               ) ;_ end of vl-catch-all-apply
             ) ;_ end of vl-catch-all-error-p
           ) ;_ end of not
      ent
      (wcmatch (strcase (cdr (assoc 0 (entget ent)))) "*LINE")
      (setq ent (vlax-ename->vla-object ent))
      ((lambda () (vla-highlight ent :vlax-true) t))
      (not (vl-catch-all-error-p
             (vl-catch-all-apply
               '(lambda ()
                  (setq pt (getpoint "\nТочка вставки результата <Отмена> : "))
                  ) ;_ end of lambda
               ) ;_ end of vl-catch-all-apply
             ) ;_ end of vl-catch-all-error-p
           ) ;_ end of not
      pt
      ) ;_ end of and
     (vla-startundomark adoc)
     (loc:unhighlight ent)
     (vla-addmtext
       (vla-objectidtoobject adoc (vla-get-ownerid ent))
       (vlax-3d-point pt)
       0
       (strcat "%<\\AcObjProp Object(%<\\_ObjId "
               (vl-princ-to-string (vla-get-objectid ent))
               ">%).Length \\f \"%.30q0\">%"
               ) ;_ end of strcat
       ) ;_ end of vla-AddMText
     (vla-endundomark adoc)
     ) ;_ end of while
  (loc:unhighlight ent)
  (princ)
  ) ;_ end of defun

(defun c:tlen1 (/ adoc ent pt *error*)
               ;|
*    Вставка текстом с последовательным выбором полилиний "по одной"
|;
  (defun loc:unhighlight (ent)
    (vl-catch-all-apply
      '(lambda ()
         (if ent
           (vla-highlight
             (cond
               ((= (type ent) 'ename) (vlax-ename->vla-object ent))
               (t ent)
               ) ;_ end of cond
             :vlax-false
             ) ;_ end of vla-highlight
           ) ;_ end of if
         ) ;_ end of lambda
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of defun

  (defun *error* (msg)
    (loc:unhighlight ent)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (while
    (and
      (not (vl-catch-all-error-p
             (vl-catch-all-apply
               '(lambda ()
                  (setq ent (car (entsel "\nУкажите полилинию <Отмена> : ")))
                  ) ;_ end of lambda
               ) ;_ end of vl-catch-all-apply
             ) ;_ end of vl-catch-all-error-p
           ) ;_ end of not
      ent
      (wcmatch (strcase (cdr (assoc 0 (entget ent)))) "*LINE")
      (setq ent (vlax-ename->vla-object ent))
      ((lambda () (vla-highlight ent :vlax-true) t))
      (not (vl-catch-all-error-p
             (vl-catch-all-apply
               '(lambda ()
                  (setq pt (getpoint "\nТочка вставки результата <Отмена> : "))
                  ) ;_ end of lambda
               ) ;_ end of vl-catch-all-apply
             ) ;_ end of vl-catch-all-error-p
           ) ;_ end of not
      pt
      ) ;_ end of and
     (vla-startundomark adoc)
     (loc:unhighlight ent)
     (vla-addtext
       (vla-objectidtoobject adoc (vla-get-ownerid ent))
       (rtos (vla-get-length ent) 2)
       (vlax-3d-point pt)
       2.5; высота текста. Не стал делать проверку на высоту текущего текстового стиля :)
       ) ;_ end of vla-AddMText
     (vla-endundomark adoc)
     ) ;_ end of while
  (loc:unhighlight ent)
  (princ)
  ) ;_ end of defun

Кочетков Андрей · 01.08.2007, 12:53

Во, пашить!
Спасибо.

Из всего кода я понял только строчку (defun c:tlen1 ())

VVA · 01.08.2007, 12:57

>Кочетков Андрей Если актуально, то строчку
(wcmatch (cdr (assoc 0 (entget en))) "*POLYLINE")
заменить
(wcmatch (cdr (assoc 0 (entget en))) "*POLYLINE,LINE")
А вот еще вариантик. Быстро переделал отсюда
http://www.autocad.ru/cgi-bin/f1/board.cgi?t=36741nT
Пишет длину вначале плиний и линии и заносит в гиперссылку. Подвел мышу и посмотрел

Код:

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

;Report Polyline Length
; Ф-ция mip-put-hyperlink
; Возвращает nil.
; Arguments [Type]:
;   Ename = Object [ENAME]
;  URLDescription = Строка [STR]
(DEFUN mip-put-hyperlink ( ENAME URLDescription )
 (if (eq (type ENAME) 'ENAME)
   (setq ENAME (vlax-ename->vla-object ENAME)))
  (vla-add (vla-get-hyperlinks ENAME) "about:blank" URLDescription)
  )      
(defun C:RPL (/ ss items i e len )
(vl-load-com)
(if (setq ss (ssget '((0 . "*POLYLINE,LINE"))))
(progn
  (setq items (mapcar (function vlax-ename->vla-object)
	            (vl-remove-if (function listp)
		      (mapcar (function cadr) (ssnamex ss))))
	  ss nil)
(mapcar '(lambda (obj / pnt txt)
(setq pnt (vlax-curve-getStartPoint obj) ;_ТОчка начала полилинии
      pnt (list (car pnt) (cadr pnt) 0.0)
      pnt (mapcar '+ pnt '(1 0 0)) ;_ 1 ед правее
      )
(setq txt (entmakex(list  '(0 . "TEXT")
 '(100 . "AcDbEntity")
 '(100 . "AcDbText")
  (cons 10 pnt)
  (cons 1 (setq len (rtos (vla-get-Length obj) 2 3)))     ;_Вместо 3 свою точность после запятой
  (cons 40 3)           ;_!!! Здесь укажи свою высоту текста вместо 3
  (cons 8 "СлойТекста") ;_!!! Здесь укажи слой текста
  '(72 . 0)             ;_Выравнивание влево
  (cons 50 0)           ;_Угол поворота
  (cons 11 pnt)         ;_ТОчка выравнивания
     )
        )
      )
(if (and txt
         (setq txt (vlax-ename->vla-object txt))
         (vlax-write-enabled-p txt)
         )
      (mip-put-hyperlink obj len))
           )
        items
        )
)
)
(princ)
)

Кочетков Андрей · 01.08.2007, 13:09

Интересный вариант, спасибо, попробую применить.

Кулик Алексей aka kpblc · 01.08.2007, 13:12

Цитата:

Сообщение от Кочетков Андрей

Во, пашить!
Спасибо.

Из всего кода я понял только строчку (defun c:tlen1 ())

Там 2 функции - одна проставляет текстом, вторая - полем. Соответственно имена tlen1 и flen1

Neznayka · 01.08.2007, 13:49

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

Цитата:

(defun C:LNG2TLB ( / en obj s row col)
(vl-load-com)
(cond
((and (setq en (car (entsel "\nВыберите таблицу: ")))
(= (cdr (assoc 0 (entget en))) "ACAD_TABLE"))
(setq obj (vlax-ename->vla-object en))
(while (and (setq en (car (entsel "\nВыберите линию (ENTER - завершение): " )))
(wcmatch (cdr (assoc 0 (entget en))) "*LINE"))
(setq s (strcat
"%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string (vla-get-objectid (vlax-ename->vla-object en)))
">%).Length>%"
))
(if (setq p (getpoint "\nУкажите ячейку таблицы: " ))(progn
(if (= :vlax-true (vla-HitTest obj
(vlax-3d-point (trans p 1 0)) (vlax-3d-point (trans (getvar "VIEWDIR") 1 0)) 'row 'col))
(vla-SetText obj row col s)
)
)) ;_endof if progn
)
)
(t
(princ "\nЭто не таблица!")
)
)
(princ)
)

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

VVA · 01.08.2007, 14:03

>Neznayka держи

Код:

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

(defun C:LNG2TLB ( / en obj s row col) 
(vl-load-com) 
(cond 
((and (setq en (car (entsel "\nВыберите таблицу: "))) 
(= (cdr (assoc 0 (entget en))) "ACAD_TABLE")) 
(setq obj (vlax-ename->vla-object en)) 
(while (and (setq en (car (entsel "\nВыберите линию (ENTER - завершение): " ))) 
(wcmatch (cdr (assoc 0 (entget en))) "*LINE"))
(setq s (strcat 
                "%<\\AcObjProp Object(%<\\_ObjId " 
                (vl-princ-to-string 
                  (vla-get-objectid (vlax-ename->vla-object en)) 
                  ) ;_ vl-princ-to-string 
                ">%).Length \\f \"%lu2%pr2\">%" 
                ) ;_ strcat 
          ) ;_ setq  
(if (setq p (getpoint "\nУкажите ячейку таблицы: " ))(progn 
(if (= :vlax-true (vla-HitTest obj 
(vlax-3d-point (trans p 1 0)) (vlax-3d-point (trans (getvar "VIEWDIR") 1 0)) 'row 'col)) 
(vla-SetText obj row col s) 
) 
)) ;_endof if progn 
) 
) 
(t 
(princ "\nЭто не таблица!") 
) 
) 
(princ) 
)

Точнось правь в этом куске

Код:

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

(setq s (strcat 
                "%<\\AcObjProp Object(%<\\_ObjId " 
                (vl-princ-to-string 
                  (vla-get-objectid (vlax-ename->vla-object en)) 
                  ) ;_ vl-princ-to-string 
                ">%).Length \\f \"%lu2%pr2\">%" 
                ) ;_ strcat 
          ) ;_ setq

pr2 - 2 знака после запятой
pr3 - 3 знака после запятой

VVA · 01.08.2007, 14:11

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

Код:

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

;_CHange Owner
(defun C:CHO ( / oldobjID newobjID txt)
(and
  (setq oldobjID (car(entsel "\nSelect old object:")))
  (setq newobjID (car(entsel "\nSelect new object:")))
  (setq txt (car(nentsel "\nSelect text:")))
  (change_owner_in_field oldobjID newobjID txt)
    )
  (princ)
  )
;_ Ф-ция заменяет владельца в поле
;_ Аргументы
;_   oldobjID - имя примитива старого владельца ID [ENAME]
;_   newobjID - имя примитива нового владельца ID [ENAME]
;_   txt      - имя примитива хранителя поля (текст или атрибут) [ENAME],
;_              возвращаемое nentsel
;_ Return
;_ T - поле обновлено
;_ nil -нет
;;;!!! Важно: новый владелец должен обладать свойством, используемым в поле

(defun change_owner_in_field ;_Ф-ция заменяет владельца в поле
                             (oldobjID ;_ Старый владелец ENAME
                              newobjID ;_ Новый владелец   ENAME
                              txt ;_ Хранитель поля (текст или атрибут) ENAME,
                                  ;_ возвращаемое nentsel
                              /           dict ;_ Словарь хранителя поля
                              field ;_ Словарь самого поля
                              field_data ;_ Значение поля (entget field)
                              New_field_data ;_Новый список для entmod
                              property ;_ Название свойства объекта в поле
                             )
  (and
  (setq dict (cdr (assoc 360 (entget txt)))) ;_Ename Dictionary Словарь примитива
  (setq dict
         (cdr (assoc 360 (member '(3 . "ACAD_FIELD") (entget dict))))
  ) ;_Enable Field Dictionary Есть поля в объекте
  (setq field (cdr (assoc 360 (member '(3 . "TEXT") (entget dict))))) ;_ Field Record Запись поля
  ;_Sub Field Records Вторичные записи полей
  (setq sub_field_list (mapcar 'cdr (vl-remove-if '(lambda(x)(/= (car x) 360))(entget field))))
    ;(setq field (cdr (assoc 360 (entget field)))) ;_Sub Field Record Вторичная запись поля
  (mapcar '(lambda(field_data)
  (setq field_data (entget field_data))
  (if (and (member (cons 330 oldobjID) field_data)
           (member (cons 331 oldobjID) field_data)
           (setq property
                  (vl-princ-to-string
                    (cdr (assoc
                           1
                           (member '(6 . "ObjectPropertyName") field_data)
                         ) ;_ end of assoc
                    ) ;_ end of cdr
                  ) ;_ end of VL-PRINC-TO-STRING
           ) ;_ end of setq
           (vlax-property-available-p
             (vlax-ename->vla-object newobjID)
             property
           ) ;_ end of vlax-property-available-p
      ) ;_ end of and
    (progn
      (setq New_field_data nil)
      (foreach itm field_data
        (cond
          ((and (= (car itm) 330)
                (equal (cdr itm) oldobjID)
           ) ;_ end of and
           (setq New_field_data
                  (append New_field_data
                          (list (cons 330 newobjID))
                  ) ;_ end of append
           ) ;_ end of setq
          )
          ((and (= (car itm) 331)
                (equal (cdr itm) oldobjID)
           ) ;_ end of and
           (setq New_field_data
                  (append New_field_data
                          (list (cons 331 newobjID))
                  ) ;_ end of append
           ) ;_ end of setq
          )
          (t (setq New_field_data (append New_field_data (list itm))))
        ) ;_ end of cond
      ) ;_ end of foreach
      (entmod New_field_data)
      (vl-cmdf "_updatefield" txt "")
      ;(while (> (getvar "CMDACTIVE") 0)(command ""))
      (entupd txt)
    ) ;_ end of progn
    nil
  ) ;_ end of if
             )
          sub_field_list
          )
  )
) ;_ end of defun

Олег К. · 01.08.2007, 14:18

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

Есть у меня один вопрос, может кто просветит.
Функция vla-get-length возвращает длину объектов, у которых есть свойство Length. Для регионов, дуг, эллипсов и сплайнов используются другие функции. Не появилось ли случайно в 2007/8 КАДах общей функции для взятия длины объекта?

Кулик Алексей aka kpblc · 01.08.2007, 14:24

Попробуй для таких штукенций использовать нечто типа (vlax-curve-getdistanceatpoint ent (vlax-curve-getendpoint ent))
P.S. Пишу без када, так что проверь имена функций.

VVA · 01.08.2007, 14:28

Только вместо point param

Код:

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

(and
(setq obj (vlax-ename->vla-object(car(entsel))))
(princ "\nДлина: ")(princ
(vlax-curve-getDistAtParam obj
  (vlax-curve-getEndParam obj)))
)

Олег К. · 01.08.2007, 15:55

Да, именно эти функции я использую для эллипсов и сплайнов. Но не подходит для мультилиний, вьюпортов... Извините, может не совсем точно был задан вопрос, интересует именно одна функция работающая со всеми объектами. Вьюпорт это конечно слишком (хотя почему? обычный многоугольник), может хоть для мультилинии упростили.
Если нет такой функции, ну и ладно, раньше ведь обходились.

Neznayka · 01.08.2007, 16:17

VVA, спасибо за модификацию

VVA · 01.08.2007, 16:50

Код:

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

;|============================================================================== 
*  Получение списка списков точек вершин ВЭ листа в координатах листа и модели 
*  Если ВЭ не существует, возвращает nil. 
*  Структура списка ((Точки_ВЭ1_Лист Точки_ВЭ1_Модель ename_ВЭ1) ... (Точки_ВЭN_Лист Точки_ВЭN_Модель ename_ВЭN))
*  Смотреть
*  http://www.autocad.ru/cgi-bin/f1/board.cgi?t=27187wE
*  http://www.arcada.com.ua/forum/viewtopic.php?t=850
*  layuot - имя листа (getvar "CTAB") или (LAYOUTLIST)
*  Возвращает список ((Точки_ВЭ1_Лист Точки_ВЭ1_Модель ename_ВЭ1) ... (Точки_ВЭN_Лист Точки_ВЭN_Модель ename_ВЭN)) 
=============================================================================|; 
(defun _mip-get-point-viewport ( layout / t10 t12 m res1 res2 nb) 
 (mapcar  '(lambda ( y / res1 x)(setq x (entget y))
  (if (cdr (assoc 340 x))
  (setq res1 (mapcar 'cdr (vl-remove-if-not '(lambda (b) (= (car b) 10))
			    (entget (cdr (assoc 340 x))))))
  (setq res1 (list
	       (list (- (cadr (assoc 10 x))(/ (cdr (assoc 40 x)) 2.))
		     (- (caddr (assoc 10 x))(/ (cdr (assoc 41 x)) 2.)))
               (list (+ (cadr (assoc 10 x))(/ (cdr (assoc 40 x)) 2.)) 
                     (- (caddr (assoc 10 x))(/ (cdr (assoc 41 x)) 2.)))
               (list (+ (cadr (assoc 10 x))(/ (cdr (assoc 40 x)) 2.)) 
                     (+ (caddr (assoc 10 x))(/ (cdr (assoc 41 x)) 2.)))
               (list (- (cadr (assoc 10 x))(/ (cdr (assoc 40 x)) 2.)) 
                     (+ (caddr (assoc 10 x)) (/ (cdr (assoc 41 x)) 2.))))))
     (setq t10 (cdr(assoc 10 x));_Координаты центра ВЭ в листе 
           t12 (if (equal (cdr(assoc 17 x)) '(0 0 0) 1e-6)(cdr(assoc 12 x))(cdr(assoc 17 x)));_Координаты центра ВЭ в Модели 
             m (/ (cdr(assoc 45 x))(cdr(assoc 41 x))) ;_Коэфф. пересчета в модель 
          res2 (mapcar '(lambda(y)(mapcar '+ (mapcar '* (mapcar '- y t10)(list m m m)) t12)) res1)) 
          (list res1 res2 y)) ;_ end of lambda
          ;;;69 1 - исключаем vieport
       (vl-remove-if '(lambda (x)(member (cons 69 1) (entget x)))
	 (if (setq nb (setq nb (ssget "_X" (list '(0 . "VIEWPORT")
                                                 '(-4 . "<>")
                                                 '(69 . 1)
                                                 (cons 410 layout)))))
		   (vl-remove-if 'listp (mapcar 'cadr (ssnamex nb)))
		   nil))) ;_ end of mapcar
  ) ;_ end of defun 



;; obj - vla object
(defun lenobj ( obj / len sum_len)
(setq sum_len 0)  
(cond
       	 ((= (strcase (vla-get-objectname obj)) "ACDBMLINE")
	  (setq ent (entget(vlax-vla-object->ename obj)))
	  (setq len (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= 11 (car x)))) ent)))
	  (if (= 2 (logand 2 (cdr(assoc 71 ent))))(setq len (append len (list (car len)))))
	  (setq ds (car len))
          (setq sum_len (+ sum_len (apply '+ (mapcar '(lambda(x / dst)(setq dst (distance ds x))(setq ds x) dst) len))))
	 )
         ((vlax-property-available-p obj 'length)
	    (setq sum_len (+ sum_len (if (vl-catch-all-error-p(vl-catch-all-apply '(lambda()(setq len (vla-get-length obj))))) 0 len))))
	 ((member (setq obj_name (strcase (vla-get-objectname obj) t)) '("acdbcircle" "acdbarc" "acdbellipse" "acdbspline"))
            (setq sum_len (+ sum_len 
                            (cond ((= obj_name "acdbcircle")(* 2 pi (vla-get-radius obj))) 
                                  ((= obj_name "acdbarc")(vla-get-ArcLength obj))
                                  ((member obj_name '("acdbellipse" "acdbspline")) 
                                    (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)))
		                  (t 0.0))))
	  )
         ((and(= (strcase (vla-get-objectname obj)) "ACDBVIEWPORT")
              (setq len (assoc
                (vlax-vla-object->ename obj)
                (mapcar 'reverse (_mip-get-point-viewport (getvar "CTAB")))))
              )
          (setq len (last len)
                len (append len (list (car len)))
                sum_len (apply '+ (mapcar 'distance len (cdr len)))
                )
          )
	 (t nil)
	   )
  sum_len
  )

Код:

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

;; Usage
(lenobj (vlax-ename->vla-object(car(entsel))))

Писал быстро, поэтому не рационально. Использовать как пример

privodnik · 17.03.2010, 10:11

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

з.ы. да, я археолог)

VVA · 17.03.2010, 15:21

Цитата:

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

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

К сожалению Александр Смирнов сменил род деятельности и перестал заниматься лиспом и Автокадом. Но его творения остались. Одно из них:

Цитата:

PDIM.LSP - This lisp for dimensioning of several LwPolylines simultaneously. The program works with current dimensional style. The distance of the dimensional text from a polyline is equal to multiplication of height of the dimensional text (DIMTEXT system variable) on a variable 'tOff'. You can change value of 'tOff' in the program beginning, after note.

AsmiTools - сборник Lisp программ от Александра Смирнова

privodnik · 17.03.2010, 15:42

Спасибо, посмотрим...а на русском описания команд нет?

VVA · 17.03.2010, 16:44

Посмотри по ссылке в комментарии

IrinaO · Регистрация: 27.05.2009

Цитата:

Сообщение от Кулик Алексей aka kpblc

_.field :?:

помогите, пожалуйста, записать эту самую длину, но не в текст, а в аттрибут блока ( блок создам предварительно). Цель - последующее суммирование этих цифр в экселе.

Garand · 22.04.2013, 17:51

Добрый день!
Можно ли в код из поста №5 добавить возможность извлечения и вставки в другие ячейки таблицы значения мультивыноски и атрибутов блоков?
Причем одним циклом: после выбора таблицы указываю один блок, второй блок, мультивыноску и полилинию, и каждый раз указываю ячейки, куда вставлять данные.
Это все нужно для создания кабельного журнала, т.е. первый атрибут - устройство, откуда идет кабель, второй - куда идет, мультивыноска - номер кабеля и длина полилинии - собственно длина кабеля.

Browning Zed · 19.01.2014, 12:22

Здравствуйте. Необходим лисп проставляющий длину линии, и при этом, одновременно, происходило бы выравнивание текста параллельно и по центру линии, с реактором (т.е при растягивании линии расположение текста относительно линии должно оставаться прежним). Вот тут уже были попытки сделать подобное, но там выводится поле, а нужен простой текст, чтобы при изменении длины линии, её изначальное значение, проставленное как текст, не менялось бы. Уважаемы знатоки LISP, помогите с решением данной проблемы.

Зодчий1989 · 13.02.2019, 09:50

Цитата:

Сообщение от Кулик Алексей aka kpblc

Те же яйца, только в профиль:

Что я сделал не так? Acad 2016x64

некорректно идентифицируется ID объекта. это связано с версией ACADa&

Код:

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

 (defun c:flen1 (/ adoc ent pt *error*)
               ;|
*    Вставка полем с последовательным выбором полилиний "по одной"
|;
  (defun loc:unhighlight (ent)
    (vl-catch-all-apply
      '(lambda ()
         (if ent
           (vla-highlight
             (cond
               ((= (type ent) 'ename) (vlax-ename->vla-object ent))
               (t ent)
               ) ;_ end of cond
             :vlax-false
             ) ;_ end of vla-highlight
           ) ;_ end of if
         ) ;_ end of lambda
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of defun

  (defun *error* (msg)
    (loc:unhighlight ent)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (while
    (and
      (not (vl-catch-all-error-p
             (vl-catch-all-apply
               '(lambda ()
                  (setq ent (car (entsel "\nУкажите полилинию <Отмена> : ")))
                  ) ;_ end of lambda
               ) ;_ end of vl-catch-all-apply
             ) ;_ end of vl-catch-all-error-p
           ) ;_ end of not
      ent
      (wcmatch (strcase (cdr (assoc 0 (entget ent)))) "*LINE")
      (setq ent (vlax-ename->vla-object ent))
      ((lambda () (vla-highlight ent :vlax-true) t))
      (not (vl-catch-all-error-p
             (vl-catch-all-apply
               '(lambda ()
                  (setq pt (getpoint "\nТочка вставки результата <Отмена> : "))
                  ) ;_ end of lambda
               ) ;_ end of vl-catch-all-apply
             ) ;_ end of vl-catch-all-error-p
           ) ;_ end of not
      pt
      ) ;_ end of and
     (vla-startundomark adoc)
     (loc:unhighlight ent)
     (vla-addmtext
       (vla-objectidtoobject adoc (vla-get-ownerid ent))
       (vlax-3d-point pt)
       0
       (strcat "%<\\AcObjProp.16.2 Object(%<\\_ObjId "
               (vl-princ-to-string (vla-get-objectid ent))
               ">%).Length \\f \"%lu2%pr2%ct8[0.001]\">%"
               ) ;_ end of strcat
       ) ;_ end of vla-AddMText
     (vla-endundomark adoc)
     ) ;_ end of while
  (loc:unhighlight ent)
  (princ)
  ) ;_ end of defun

Кулик Алексей aka kpblc · 13.02.2019, 11:00

Это связано с ограничениями LISP: он не умеет оперировать с 64-разрядными целыми. Самое простое решение - это преобразовать объект в ename, вывести его в строку, отфильтровать то, что идет после символа ":", и преобразовать остаток в десятичную систему из 16-ричной. Функции соответствующие на этом форуме, насколько я помню, были.

Сергей812 · 13.02.2019, 11:01

Цитата:

Сообщение от Зодчий1989

некорректно идентифицируется ID объекта. это связано с версией ACADa&

Возможно - тыц (autolisp.ru)

Зодчий1989 · 13.02.2019, 12:04

Цитата:

Сообщение от Сергей812

Возможно - тыц (autolisp.ru)

Увы программирование на уровне паскаля( эту проблему данными мне мозгами быстро не решить.

Кулик Алексей aka kpblc · 13.02.2019, 13:31

Сергей812, там информация немного устарела. Спасибо, подправлю сегодня (по крайней мере на это надеюсь)

Только что добавил статейку: http://autolisp.ru/2019/02/14/objectid-for-fields/

VVA · 13.02.2019, 15:12

Зодчий1989, Попробуй в строке 60 вместо vla-get-objectid использовать функцию Get-ObjectID-x86-x64

Код:

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

(strcat "%<\\AcObjProp.16.2 Object(%<\\_ObjId "
               (vl-princ-to-string (Get-ObjectID-x86-x64  ent))
               ">%).Length \\f \"%lu2%pr2%ct8[0.001]\">%"
               ) ;_ end of strcat

Зодчий1989 · 14.02.2019, 07:22

Цитата:

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

VVA

,

Цитата:

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

вместо vla-get-objectid использовать функцию Get-ObjectID-x86-x64

Идеально работает. Может пригодится кому нибудь.
Программа извлекает свойство (указывается в строке 61 ">%).Area \\f \"%lu2%pr2%ct8[1e-006]\">%}") из полилинии и вставляет в пространство листа "полем" ACADa.

Код:

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

  (defun c:farea (/ adoc ent pt *error*)
               ;|
*    Вставка полем с последовательным выбором полилиний "по одной"
|;
  (defun loc:unhighlight (ent)
    (vl-catch-all-apply
      '(lambda ()
         (if ent
           (vla-highlight
             (cond
               ((= (type ent) 'ename) (vlax-ename->vla-object ent))
               (t ent)
               ) ;_ end of cond
             :vlax-false
             ) ;_ end of vla-highlight
           ) ;_ end of if
         ) ;_ end of lambda
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of defun

  (defun *error* (msg)
    (loc:unhighlight ent)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (while
    (and
      (not (vl-catch-all-error-p
             (vl-catch-all-apply
               '(lambda ()
                  (setq ent (car (entsel "\nУкажите полилинию <Отмена> : ")))
                  ) ;_ end of lambda
               ) ;_ end of vl-catch-all-apply
             ) ;_ end of vl-catch-all-error-p
           ) ;_ end of not
      ent
      (wcmatch (strcase (cdr (assoc 0 (entget ent)))) "*LINE")
      (setq ent (vlax-ename->vla-object ent))
      ((lambda () (vla-highlight ent :vlax-true) t))
      (not (vl-catch-all-error-p
             (vl-catch-all-apply
               '(lambda ()
                  (setq pt (getpoint "\nТочка вставки результата <Отмена> : "))
                  ) ;_ end of lambda
               ) ;_ end of vl-catch-all-apply
             ) ;_ end of vl-catch-all-error-p
           ) ;_ end of not
      pt
      ) ;_ end of and
     (vla-startundomark adoc)
     (loc:unhighlight ent)
     (vla-addmtext
       (vla-objectidtoobject adoc (vla-get-ownerid ent))
       (vlax-3d-point pt)
       0
       (strcat "{\\L%<\\AcObjProp.16.2 Object(%<\\_ObjId "
               (vl-princ-to-string (get-objectid-x86-x64 ent))
               ">%).Area \\f \"%lu2%pr2%ct8[1e-006]\">%}"
               ) ;_ end of strcat
       ) ;_ end of vla-AddMText
     (vla-endundomark adoc)
     ) ;_ end of while
  (loc:unhighlight ent)
  (princ)
  ) ;_ end of defun
;;--------------------------------------------------------
;; Функция получает строковое представление ObjectID
;; вне зависимости от того AutoCAD x86 или x64
;; Источник: https://discussion.autodesk.com/forums/message.jspa?messageID=6172961
;;--------------------------------------------------------
(defun Get-ObjectID-x86-x64 (obj / util)
  (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
  (if (= (type obj) 'VLA-OBJECT)
     (if (> (vl-string-search "x64" (getvar "platform")) 0)
       (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
       (rtos (vla-get-objectid obj) 2 0)
     )
  )
) ;_ end of defun

01.08.2007, 11:25		#1
Добавление в чертеж длины полилинии Кочетков Андрей Java/Kotlin/Go Регистрация: 03.02.2006 Сообщений: 5,786 Господа программисты, нужна ваша помощь. Мне нужна программа которая делает следующее: тыркаем в полилинию, затем тыркаем в произвольную точку чертежа и в этой точке создается текст, содержимым которого является длина раннее "тыркнутой" полилинии. Попытался сам сделать, но на создании текста застопорился, а на эксперименты нет времени.
Просмотров: 17039