Макрос для измерения длины, высоты и площади блоков на чертеже

Автор Тема: Макрос для измерения длины, высоты и площади блоков на чертеже  (Прочитано 4563 раз)

0 Пользователей и 1 Гость просматривают эту тему.

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Идея родилась в связи с тем, что используем блоки, которые несут в себе информацию о фасадах зданий, и автоматизация расчета геометрии оказалась очень полезным подспорьем
Огромная благодарность Александру Ривилису за определения точных границ задачи и VVA за фрагмент кода  с форума dwg.ru
Приятным бонусом кода является то, что полученная информация разносится по таблицам, а также производится суммирование длин и площадей всех требуемых блоков, также с занесением в таблицу; учитывается масштаб блоков

Код - Auto/Visual Lisp [Выбрать]
  1. (defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc)
  2. (setq pt (trans pt 0 1))
  3. (setq VCTR (getvar "VIEWCTR") Y_Len (getvar "VIEWSIZE")
  4.    SSZ (getvar "SCREENSIZE") X_Pix (car SSZ) Y_Pix (cadr SSZ)
  5.    X_Len (* (/ X_Pix Y_Pix) Y_Len)
  6.    Lc (polar VCTR (dtr 180.0) (* 0.5 X_Len))
  7.    Uc (polar Lc 0.0 X_Len) Lc (polar Lc (dtr 270.0) (* 0.5 Y_Len))
  8.    Uc (polar Uc (dtr 90.0) (* 0.5 Y_Len)))
  9. (if (and (> (car pt) (car Lc))(< (car pt) (car Uc))
  10.    (> (cadr pt) (cadr Lc))(< (cadr pt) (cadr Uc))) T nil))
  11. (defun DTR (a)(* pi (/ a 180.0)))(defun RTD (a)(/ (* a 180.0) pi))
  12. ; ! ***********************************************************
  13. ;; !                             lib:Zoom2Lst
  14. ;; ! **********************************************************
  15. ;; ! Function : Zoom границ списка точек
  16. ;; ! Arguments: 'vlist' — Список точек в МСК!!!!
  17. ;; ! Зуммирует экран, чтобы все точки были видны
  18. ;; ! Returns  : t — было зуммирование nil — нет
  19. ;; ! **********************************************************
  20. (defun lib:Zoom2Lst( vlist / bl tr Lst OS)
  21. (setq  Lst (lib:pt_extents vlist) bl (car Lst) tr (cadr Lst))
  22. (if (not (and (lib:IsPtInView bl) (lib:IsPtInView tr)))
  23. (progn  (setq OS (getvar "OSMODE"))(setvar "OSMODE" 0)
  24.   (command "_.Zoom" "_Window" (trans bl 0 1)(trans tr 0 1) "_.Zoom" "0.95x")
  25.   (setvar "OSMODE" OS) T) NIL))
  26. ;| ! ***************************************************************************
  27. ;; !           lib:pt_extents
  28. ;; ! ***************************************************************************
  29. ;; ! Function : Возвращает границы MIN, MAX X,Y,Z списка точек
  30. ;; ! Argument : 'vlist' — Список точек
  31. ;; ! Returns  : Список точек (ЛевНижн ПравВерхн)
  32. ;; ! ***************************************************************************|;
  33. (defun  lib:pt_extents (vlist / tmp)
  34. (setq tmp (mapcar '(lambda (x) (vl-remove-if 'null x))
  35. (mapcar '(lambda (what) (mapcar '(lambda (x) (nth what x)) vlist)) '(0 1 2))));_setq
  36.   (list (mapcar '(lambda(x)(apply 'min x)) tmp)(mapcar '(lambda(x)(apply 'max x)) tmp)));_defun
  37. ;http://www.caduser.ru/forum/index.php...&TID=30797
  38. ;External contour of objects
  39.  
  40.  
  41. (defun c:sv_tabl ( / alltext _textfind _textfor kscale _block _name_fas minpoint_l maxpoint_l minpoint_h maxpoint_h diff_l diff_h _sum _sum_sq  )
  42.   (vl-load-com)
  43.   (setq _sum 0.0 )
  44.   (setq _sum_sq 0.0 )
  45.   (setq alltext (ssget "_X" (list (cons 1 "*00   }") (cons 0 "Mtext"))))
  46.   (setq _textfind (vlax-ename->vla-object (ssname alltext 0)))
  47.   (setq _textfor (vla-get-TextString _textfind))
  48.   (if (wcmatch _textfor "*100   }") (setq kscale 0.1) (setq kscale 0.2))
  49.   (setq _acad (vlax-get-acad-object))
  50.   (setq active_doc (vla-get-ActiveDocument _acad))
  51.   (setq m_space (vla-get-ModelSpace active_doc))
  52.   (setq _blockselect (ssget "_X" (list (cons 2 "фасад*") (cons 0 "Insert"))))
  53.   (setq counter 0)
  54.   (while (< counter (sslength _blockselect))
  55.   (setq _block (vlax-ename->vla-object (ssname _blockselect counter)))
  56.   (setq _name_fas (vla-get-name _block))
  57.   (vla-getboundingbox _block 'minpoint 'maxpoint)
  58.   (setq minpoint_l (nth 0 (vlax-safearray->list minpoint)))
  59.   (setq maxpoint_l (nth 0 (vlax-safearray->list maxpoint)))
  60.   (setq minpoint_h (nth 1 (vlax-safearray->list minpoint)))
  61.   (setq maxpoint_h (nth 1 (vlax-safearray->list maxpoint)))
  62.   (setq diff_l (* kscale (- maxpoint_l minpoint_l)))
  63.   (setq diff_h (* kscale (- maxpoint_h minpoint_h)))
  64.     (setq l (rtos diff_l 2 1))
  65.     (princ (strcat "Длина "_name_fas":" l "м") )
  66.     (terpri)
  67.     (defun _part ( / *error* blk obj MinPt MaxPt hiden pt pl unnamed_block isRus
  68.          tmp_blk adoc blks lays lay oname sel csp loc sc ec ret DS osm)
  69.     (defun *error* (msg)(mapcar '(lambda (x) (vla-put-Visible x :vlax-true)) hiden)
  70. (vla-endundomark adoc)(if (and tmp_blk (not (vlax-erased-p tmp_blk))(vlax-write-enabled-p tmp_blk) )
  71. (vla-Erase tmp_blk))(if osm (setvar "OSMODE" osm))(foreach x loc (vla-put-lock x :vlax-true)))
  72. (vl-load-com)(setvar "CMDECHO" 0)(setq osm (getvar "OSMODE"))
  73. (if (zerop (getvar "WORLDUCS"))(progn(vl-cmdf "_.UCS" "")(vl-cmdf "_.Plan" "")))
  74. (setq isRus (= (getvar "SysCodePage") "ANSI_1251"))
  75. (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
  76.         blks (vla-get-blocks adoc) lays (vla-get-layers adoc))
  77.   (vla-startundomark adoc)(if isRus (princ (strcat "\nВыберите объекты для построения контура,"_name_fas":"))(princ (strcat "\nSelect objects for making a contour,"_name_fas":")))
  78. (if (setq sel (ssget))(progn
  79.     (setq sel (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex sel)))))
  80.     (setq csp (vla-objectidtoobject adoc (vla-get-ownerid (car sel))))
  81.     (setq unnamed_block (vla-add (vla-get-blocks adoc)(vlax-3d-point '(0. 0. 0.)) "*U"))
  82.     (foreach x sel
  83.       (setq oname (strcase (vla-get-objectname x)) lay  (vla-item lays (vla-get-layer x)))
  84.         (if (= (vla-get-lock lay) :vlax-true)
  85.           (progn (vla-put-lock lay :vlax-false) (setq loc (cons lay loc))))
  86.       (cond ((member oname '("ACDBVIEWPORT" "ACDBATTRIBUTEDEFINITION")) nil)
  87.        ((= oname "ACDBBLOCKREFERENCE")
  88.         (vla-InsertBlock unnamed_block
  89.           (vla-get-insertionpoint x)(vla-get-name x)
  90.           (vla-get-xscalefactor x)(vla-get-yscalefactor x)
  91.           (vla-get-zscalefactor x)(vla-get-rotation x))
  92.         (setq blk (cons x blk)))
  93.        (t (setq obj (cons x obj)))));_foreach
  94.         (setq lay  (vla-item lays (getvar "CLAYER")))
  95.         (if (= (vla-get-lock lay) :vlax-true)(progn (vla-put-lock lay :vlax-false) (setq loc (cons lay loc))))
  96.      (if obj (progn (vla-copyobjects (vla-get-activedocument (vlax-get-acad-object))
  97.               (vlax-make-variant (vlax-safearray-fill
  98.                   (vlax-make-safearray vlax-vbobject (cons 0 (1- (length obj))))
  99.                   obj)) unnamed_block)))
  100.     (setq obj (append obj blk))
  101.     (if obj (progn
  102.           (setq tmp_blk (vla-insertblock csp (vlax-3d-point '(0. 0. 0.))(vla-get-name unnamed_block) 1.0 1.0 1.0 0.0))
  103.           (vla-GetBoundingBox tmp_blk 'MinPt 'MaxPt)  ;_Границы блока
  104.                (setq MinPt (vlax-safearray->list MinPt) MaxPt (vlax-safearray->list MaxPt)
  105.            DS (max (distance MinPt (list (car MinPt)(cadr MaxPt)))
  106.               (distance MinPt (list (car MaxPt)(cadr MinPt))))
  107.                 DS (* 0.2 DS) ;1/5
  108.            DS (max DS 10) MinPt (mapcar '- MinPt (list DS DS))
  109.                      MaxPt (mapcar '+ MaxPt (list DS DS)))
  110. (lib:Zoom2Lst (list MinPt MaxPt))(setq sset (ssget "_C" MinPt MaxPt))
  111. (if sset (progn (setvar "OSMODE" 0)
  112.       (setq hiden (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex sset))))
  113.        hiden (vl-remove tmp_blk hiden))
  114.       (mapcar '(lambda(x)(vla-put-Visible x :vlax-false)) hiden)
  115.       (setq pt (mapcar '+ MinPt (list (* 0.5 DS)(* 0.5 DS))))
  116.       (vl-cmdf "_.RECTANG" (trans MinPt 0 1)(trans MaxPt 0 1))
  117.       (setq pl (vlax-ename->vla-object(entlast)))
  118.       (setq sc (1-(vla-get-count csp)))
  119.       (if (VL-CATCH-ALL-ERROR-P (VL-CATCH-ALL-APPLY '(lambda ()
  120.          (vl-cmdf "_-BOUNDARY" (trans pt 0 1) "")
  121.               (while (> (getvar "CMDACTIVE") 0)(command "")))))
  122.       (if isRus (princ "\nНе удалось построить контур")(princ "\nIt was not possible to construct a contour")))
  123.       (setq ec (vla-get-count csp))
  124.         (while (< sc ec)(setq ret (append ret (list (vla-item csp sc))) sc(1+ sc)))
  125.       (setq ret (vl-remove pl ret))
  126.       (mapcar '(lambda (x)(vla-Erase x)(vlax-release-object x))(list pl tmp_blk))(setq pl nil tmp_blk nil)
  127.       (setq ret (mapcar '(lambda ( x / mipt)(vla-GetBoundingBox x 'MiPt nil)  ;_Границы блока
  128.                  (setq MiPt (vlax-safearray->list MiPt))(list MiPt x)) ret))
  129.       (setq ret (vl-sort ret '(lambda (e1 e2)(< (distance MinPt (car e1))(distance MinPt (car e2))))))
  130.       (setq pl (nth 1 ret) ret (vl-remove pl ret))(mapcar 'vla-erase (mapcar 'cadr ret))
  131.       (mapcar '(lambda(x)(vla-put-Visible x :vlax-true)) hiden)
  132.       (foreach x loc (vla-put-lock x :vlax-true))
  133.       (if pl (progn (initget  "Yes No")
  134.       (if (= (getkword (if isRus "\nУдалять объекты? [Yes/No] <No> : " "\nDelete objects? [Yes/No] <No> : ")) "Yes")
  135.          (mapcar '(lambda (x) (if (vlax-write-enabled-p x)(vla-Erase x))) obj)))
  136.    (if isRus (princ "\nНе удалось построить контур")(princ "\nIt was not possible to construct a contour")))))))
  137.      (VL-CATCH-ALL-APPLY '(lambda ()(mapcar 'vlax-release-object
  138.     (list unnamed_block tmp_blk csp blks lays))))));_if not
  139.   (foreach x loc (vla-put-lock x :vlax-true))(setvar "OSMODE" osm)
  140.   (vla-endundomark adoc)(vlax-release-object adoc)(princ)
  141. (setq sq_a (* 0.01 (vlax-get-property (vlax-ename->vla-object(entlast)) 'area)))
  142.   (princ (strcat "Площадь:"(rtos sq_a 2 1)" м2" ))
  143. (terpri)
  144.     (vla-erase (vlax-ename->vla-object(entlast))))
  145.     (_part)
  146.    
  147.     (setq _table (ssget "_X" (list (cons 1 (strcat "Характеристика здания ("_name_fas") " )) (cons 0 "ACAD_TABLE"))))
  148.   (setq _t (vlax-ename->vla-object (ssname _table 0)))
  149. (vla-settext _t 3 1 l )
  150.   (vla-settext _t 1 1 (rtos diff_h 2 1))
  151.   (vla-settext _t 2 1 (rtos sq_a 2 1 ))
  152.  
  153.   (setq _sum (+ _sum diff_l))
  154.     (setq _sum_sq (+ _sum_sq sq_a))
  155.    
  156.         (setq counter (+ counter 1)))
  157.   (princ (strcat "\nСуммарная длина фасадов:" (rtos _sum 2 1) "м"))
  158.   (princ (strcat "\nСуммарная площадь фасадов:" (rtos _sum_sq 2 1) "м2"))
  159.   (terpri)
  160.     (setq a (rtos _sum 2 1))
  161.     (setq b (rtos _sum_sq 2 1))
  162.     (setq _tablex (ssget "_X" (list (cons 1 "Характеристика зданий") (cons 0 "ACAD_TABLE"))))
  163.     (setq _t (vlax-ename->vla-object (ssname _tablex 0)))
  164.     (vla-settext _t 2 1 a)
  165.     (vla-settext _t 1 1 b)
  166.    
  167.      
  168.  
  169.   )
Для наглядности выкладываю файл с примером
« Последнее редактирование: 24-10-2014, 14:16:42 от Александр Ривилис »

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
У меня только одно замечание. По терминологии. В AutoCAD у блока нет ни длины, ни высоты, ни площади. Есть масштабные коэффициенты по X,Y,Z. Есть габаритный контейнер, в который блок (а точнее вставка блока) вписывается.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение