跪求，多个PL线面积标注，和多个PL线面积导出的lisp

838510233

很多个pl线围成多边形，想标注面积，图层随便设置，字体1，颜色要白色。。最后把呢些多边形的面积 导出来，excel格式，或TXT（随便隔开点）。。。

likai1121

这个怎么提示出错啊

wangshuping42

newbuser

838510233

newbuser 发表于 2015-1-8 08:49

能发给我用下吗？

newbuser

838510233 发表于 2015-1-8 10:03
能发给我用下吗？

不是很成熟啊，用了一个Gu_xl版主的一个vlx，将直线，请注意是直线生成闭合多段线的程序，再然后就是标注面积并将面积提取到txt文本的东西。

2. ;;-------------------------------------------------------------
   
3. ;;批量标注多边形面积（已做比例1/1000^2处理）
   
4. ;;-------------------------------------------------------------
   
5. (defun c:plmj ( / ee h i slst ss vlalst x xy)
   
6. (vl-load-com)
   
7. (setq ss (ssget '((0 . "LWPOLYLINE"))))
   
8. (setq slst (ss-en ss))
   
9. (setq slst
   
10.    (vl-remove-if
    
11.      'not
    
12.      (mapcar
    
13.        '(lambda (x)
    
14.     (if
    
15.       (= (vlax-curve-isClosed (vlax-ename->vla-object x)) T) ;;判断为闭合的图元名组表
    
16.        x
    
17.     )
    
18.         )
    
19.        slst
    
20.      )
    
21.    )
    
22.   )
    
23. (setq vlalst (mapcar 'vla-get-Area (mapcar 'vlax-ename->vla-object slst)))
    
24.   (setq i 0)
    
25.   (repeat (length slst)
    
26.     (bwh (nth i slst))
    
27.     (setq ee (emake (* (nth i vlalst) 1) xy h))
    
28. ;;;    (entmod ee)
    
29.     (setq i (1+ i))
    
30.   )
    
31.   (princ)
    
32. )
    
33. 
    
34. ;;=====================================================
    
35. ;;文本内容提取
    
36. (defun c:tqwb (/ e elist fn fna i ss v1 v10 v8 vlist)
    
37.   (princ "\n文本提取程序 carrot1983 2008/11/13")
    
38.   (if (and
    
39.   (setq ss (ssget '((0 . "*TEXT*"))))
    
40.   (setq fna (getfiled "保存文本提取的信息" "" "txt" 5))
    
41.       )
    
42.     (progn
    
43.       (setq i 0)
    
44.       (while (< i (sslength ss))
    
45.   (setq e (ssname ss i))
    
46.   (setq elist (entget e))
    
47.   (setq v1 (cdr (assoc 1 elist)))
    
48.   (setq v10 (cdr (assoc 10 elist)))
    
49.   (setq v10 (mapcar 'rtos v10))
    
50.   (setq v8 (cdr (assoc 8 elist)))
    
51.   (setq vlist (cons (strcat v1
    
52.           ","
    
53.           (car v10)
    
54.           ","
    
55.           (cadr v10)
    
56.           ","
    
57.           (caddr v10)
    
58.           ","
    
59.           v8
    
60.         )
    
61.         vlist
    
62.         )
    
63.   )
    
64.   (setq i (1+ i))
    
65.       )
    
66.       (setq fn (open fna "w"))
    
67.       (write-line "内容,X,Y,Z,图层" fn)
    
68.       (foreach v vlist
    
69.   (write-line v fn)
    
70.       )
    
71.       (close fn)
    
72.       (startapp "notepad" fna)
    
73.     )
    
74.   )
    
75.   (princ)
    
76. )

;;-------------------------------------------------------------<br /> ;;批量标注多边形面积（已做比例1/1000^2处理）<br /> ;;-------------------------------------------------------------<br /> (defun c:plmj ( / ee h i slst ss vlalst x xy)<br /> (vl-load-com)<br /> (setq ss (ssget '((0 . "LWPOLYLINE"))))<br /> (setq slst (ss-en ss))<br /> (setq slst<br />    (vl-remove-if<br />      'not<br />      (mapcar<br />        '(lambda (x)<br />     (if<br />       (= (vlax-curve-isClosed (vlax-ename->vla-object x)) T) ;;判断为闭合的图元名组表<br />        x<br />     )<br />         )<br />        slst<br />      )<br />    )<br />   )<br /> (setq vlalst (mapcar 'vla-get-Area (mapcar 'vlax-ename->vla-object slst)))<br />   (setq i 0)<br />   (repeat (length slst)<br />     (bwh (nth i slst))<br />     (setq ee (emake (* (nth i vlalst) 1) xy h))<br /> ;;;    (entmod ee)<br />     (setq i (1+ i))<br />   )<br />   (princ)<br /> )<br /> <br /> ;;=====================================================<br /> ;;文本内容提取<br /> (defun c:tqwb (/ e elist fn fna i ss v1 v10 v8 vlist)<br />   (princ "\n文本提取程序 carrot1983 2008/11/13")<br />   (if (and<br />   (setq ss (ssget '((0 . "*TEXT*"))))<br />   (setq fna (getfiled "保存文本提取的信息" "" "txt" 5))<br />       )<br />     (progn<br />       (setq i 0)<br />       (while (< i (sslength ss))<br />   (setq e (ssname ss i))<br />   (setq elist (entget e))<br />   (setq v1 (cdr (assoc 1 elist)))<br />   (setq v10 (cdr (assoc 10 elist)))<br />   (setq v10 (mapcar 'rtos v10))<br />   (setq v8 (cdr (assoc 8 elist)))<br />   (setq vlist (cons (strcat v1<br />           ","<br />           (car v10)<br />           ","<br />           (cadr v10)<br />           ","<br />           (caddr v10)<br />           ","<br />           v8<br />         )<br />         vlist<br />         )<br />   )<br />   (setq i (1+ i))<br />       )<br />       (setq fn (open fna "w"))<br />       (write-line "内容,X,Y,Z,图层" fn)<br />       (foreach v vlist<br />   (write-line v fn)<br />       )<br />       (close fn)<br />       (startapp "notepad" fna)<br />     )<br />   )<br />   (princ)<br /> )

akakak68

newbuser 发表于 2015-1-8 10:47
不是很成熟啊，用了一个Gu_xl版主的一个vlx，将直线，请注意是直线生成闭合多段线的程序，再然后就是标注 ...

支持2015版CAD不

newbuser

akakak68 发表于 2015-1-8 17:18
支持2015版CAD不

一般不是特别高深的程序是全支持型的。
即便是受版本限制也是Gu版的程序，他的水平高，凭他一人之力就可以做2020版本的cad了。

红珊瑚89

newbuser 发表于 2015-1-8 10:47
不是很成熟啊，用了一个Gu_xl版主的一个vlx，将直线，请注意是直线生成闭合多段线的程序，再然后就是标注 ...

大神，我不会VB，请问下这个怎么加载到CAD中啊

yanghz1977

newbuser 发表于 2015-1-8 10:47
不是很成熟啊，用了一个Gu_xl版主的一个vlx，将直线，请注意是直线生成闭合多段线的程序，再然后就是标注 ...

谢谢分享，下个试下，顶。。。。。

imaya

newbuser 发表于 2015-1-8 10:47
不是很成熟啊，用了一个Gu_xl版主的一个vlx，将直线，请注意是直线生成闭合多段线的程序，再然后就是标注 ...

把直线圈定变成多边型的工具真好用。就是在本标注面积时，出现“误: no function definition: SS-EN”