Pline命令加标注面积

Free-Lancer

1. (defun c:tt (/ le pts e el n p)
   
2.   (setq le (entlast))
   
3.   (fy:begin)
   
4.   (fy:setv "cmdecho" 1)
   
5.   ;;(setvar "cmdecho" 1)
   
6.   (vl-cmdf ".pline")
   
7.   (while (/= (getvar "cmdactive") 0)
   
8.     (vl-cmdf pause)
   
9.   )
   
10.   (if (not (equal (setq e (entlast)) le))
    
11.     (progn
    
12.       (if (not (vlax-curve-isclosed e))
    
13.         (vla-put-closed
    
14.           (vlax-ename->vla-object e)
    
15.           :vlax-true
    
16.         )
    
17.       )
    
18.       (setq pts        (mapcar        'cdr
    
19.                         (vl-remove-if
    
20.                           '(lambda (x) (/= (car x) 10))
    
21.                           (setq el (entget e))
    
22.                         )
    
23.                 )
    
24.             n        (cdr (assoc 90 el))
    
25.             p        (list
    
26.                   (/ (apply '+ (mapcar 'car pts)) n)
    
27.                   (/ (apply '+ (mapcar 'cadr pts)) n)
    
28.                 )
    
29.       )
    
30.       (entmake (list '(0 . "text")
    
31.                      '(100 . "AcDbEntity")
    
32.                      '(100 . "AcDbText")
    
33.                      (cons 1 (rtos (vlax-curve-getarea e) 2 3))
    
34.                      (cons 10 p)
    
35.                      (cons 40 (getvar "textsize"))
    
36.                      '(50 . 0.)
    
37.                )
    
38.       )
    
39.     )
    
40.   )
    
41.   (fy:end)
    
42.   ;;(setvar "cmdecho" 0)
    
43.   (princ)
    
44. )

(defun c:tt (/ le pts e el n p)<br />   (setq le (entlast))<br />   (fy:begin)<br />   (fy:setv "cmdecho" 1)<br />   ;;(setvar "cmdecho" 1)<br />   (vl-cmdf ".pline")<br />   (while (/= (getvar "cmdactive") 0)<br />     (vl-cmdf pause)<br />   )<br />   (if (not (equal (setq e (entlast)) le))<br />     (progn<br />       (if (not (vlax-curve-isclosed e))<br />         (vla-put-closed<br />           (vlax-ename->vla-object e)<br />           :vlax-true<br />         )<br />       )<br />       (setq pts        (mapcar        'cdr<br />                         (vl-remove-if<br />                           '(lambda (x) (/= (car x) 10))<br />                           (setq el (entget e))<br />                         )<br />                 )<br />             n        (cdr (assoc 90 el))<br />             p        (list<br />                   (/ (apply '+ (mapcar 'car pts)) n)<br />                   (/ (apply '+ (mapcar 'cadr pts)) n)<br />                 )<br />       )<br />       (entmake (list '(0 . "text")<br />                      '(100 . "AcDbEntity")<br />                      '(100 . "AcDbText")<br />                      (cons 1 (rtos (vlax-curve-getarea e) 2 3))<br />                      (cons 10 p)<br />                      (cons 40 (getvar "textsize"))<br />                      '(50 . 0.)<br />                )<br />       )<br />     )<br />   )<br />   (fy:end)<br />   ;;(setvar "cmdecho" 0)<br />   (princ)<br /> )

fjb54007

正需要，谢谢楼主分享

Newbuser

缺少三个函数啊哥。

xvjiex

感谢楼主分享Pline命令加标注面积

hh_lj007

谢谢楼主分享，缺少三个函数啊哥。

willclark

正需要，谢谢楼主分享