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

[Peacemaker_kiss]

Идея родилась в связи с тем, что используем блоки, которые несут в себе информацию о фасадах зданий, и автоматизация расчета геометрии оказалась очень полезным подспорьем
Огромная благодарность Александру Ривилису за определения точных границ задачи и 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.   )

Для наглядности выкладываю файл с примером

[Александр Ривилис]

У меня только одно замечание. По терминологии. В AutoCAD у блока нет ни длины, ни высоты, ни площади. Есть масштабные коэффициенты по X,Y,Z. Есть габаритный контейнер, в который блок (а точнее вставка блока) вписывается.