多段线面积标高到TXT，自娱自乐

树櫴希德

1. (defun vxs (e / i v lst)
   
2.   (setq i 0)
   
3.   (while
   
4.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
   
5.      (setq lst (cons v lst))
   
6.   )
   
7.   (reverse lst))
   
8. ;;;;;;;;;;;;;;;
   
9. (defun 38zu ( e / e)
   
10.   (cdr(assoc 38(entget e)))
    
11.   )
    
12. 
    
13. 
    
14. (defun c:tt11 ( / lst ent pts pt demj zmj ffn ff) ;标记三角网表面积
    
15. 
    
16.   (setq lst (ssget '( (0 . "*polyline") (8 . "S-CAP")) ) )
    
17. (setq i 0)
    
18. (setq zmj 0.000)
    
19. (setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1))
    
20.   (setq ff (open ffn "w"))
    
21. 
    
22.   
    
23. (while  (< i (sslength lst))
    
24. 
    
25. (setq ent (ssname lst i))
    
26. 
    
27. (setq pts (vxs ent))
    
28.   (setq len (length pts))
    
29. (setq pt (mapcar
    
30.   '(lambda(x)
    
31.     (/ x len)
    
32.   )
    
33.   (apply
    
34.     'mapcar
    
35.     (cons '+ pts)
    
36.   )
    
37. )
    
38. )
    
39. 
    
40. (setq    AcadObject   (vlax-get-acad-object)
    
41. 
    
42.           AcadDocument (vla-get-ActiveDocument Acadobject)
    
43. 
    
44.           mSpace    (vla-get-ModelSpace Acaddocument)) ;初始化系统
    
45. 
    
46. 
    
47.   
    
48. 
    
49.   (setq demj (vlax-curve-getArea  (vlax-ename->vla-object ent)))
    
50.   
    
51.   (entmake (list (cons 0  "TEXT") (cons 1 (rtos (+ i 1) 2 0)) (cons 10 (polar pt (* 0.5 pi) 0.5)  )
    
52.                (cons 40 0.3)
    
53.                (cons 8 "三角网表面积")
    
54.                ))
    
55. (entmake (list (cons 0  "TEXT") (cons 1 (strcat "面积"(rtos demj 2 3))) (cons 10 pt)
    
56.                (cons 40 0.3)
    
57.                (cons 8 "三角网表面积")
    
58.                ))
    
59.   (entmake (list (cons 0  "TEXT") (cons 1 (strcat "深度"(rtos (38zu ent) 2 3) )) (cons 10 (polar pt (* 1.5 pi) 0.5)  )
    
60.                (cons 40 0.3)
    
61.                (cons 8 "三角网表面积")
    
62.                ))
    
63. 
    
64. 
    
65. 
    
66.   
    
67.   (princ (strcat (rtos (+ i 1) 2 0)","(rtos demj 2 3) "," (rtos (38zu ent) 2 3) "\n"
    
68.     ) ff)
    
69. 
    
70. 
    
71.   
    
72.   
    
73.   
    
74. ;(setq zmj(+ zmj demj))
    
75. 
    
76. (setq i (+ i 1))
    
77.   
    
78.   
    
79.   )
    
80. 
    
81. (close ff)
    
82.   (princ)
    
83. 
    
84. )

(defun vxs (e / i v lst)<br />   (setq i 0)<br />   (while<br />     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))<br />      (setq lst (cons v lst))<br />   )<br />   (reverse lst))<br /> ;;;;;;;;;;;;;;;<br /> (defun 38zu ( e / e)<br />   (cdr(assoc 38(entget e)))<br />   )<br /> <br /> <br /> (defun c:tt11 ( / lst ent pts pt demj zmj ffn ff) ;标记三角网表面积<br /> <br />   (setq lst (ssget '( (0 . "*polyline") (8 . "S-CAP")) ) )<br /> (setq i 0)<br /> (setq zmj 0.000)<br /> (setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1))<br />   (setq ff (open ffn "w"))<br /> <br />   <br /> (while  (< i (sslength lst))<br /> <br /> (setq ent (ssname lst i))<br /> <br /> (setq pts (vxs ent))<br />   (setq len (length pts))<br /> (setq pt (mapcar<br />   '(lambda(x)<br />     (/ x len)<br />   )<br />   (apply<br />     'mapcar<br />     (cons '+ pts)<br />   )<br /> )<br /> )<br /> <br /> (setq    AcadObject   (vlax-get-acad-object)<br /> <br />           AcadDocument (vla-get-ActiveDocument Acadobject)<br /> <br />           mSpace    (vla-get-ModelSpace Acaddocument)) ;初始化系统<br /> <br /> <br />   <br /> <br />   (setq demj (vlax-curve-getArea  (vlax-ename->vla-object ent)))<br />   <br />   (entmake (list (cons 0  "TEXT") (cons 1 (rtos (+ i 1) 2 0)) (cons 10 (polar pt (* 0.5 pi) 0.5)  )<br />                (cons 40 0.3)<br />                (cons 8 "三角网表面积")<br />                ))<br /> (entmake (list (cons 0  "TEXT") (cons 1 (strcat "面积"(rtos demj 2 3))) (cons 10 pt)<br />                (cons 40 0.3)<br />                (cons 8 "三角网表面积")<br />                ))<br />   (entmake (list (cons 0  "TEXT") (cons 1 (strcat "深度"(rtos (38zu ent) 2 3) )) (cons 10 (polar pt (* 1.5 pi) 0.5)  )<br />                (cons 40 0.3)<br />                (cons 8 "三角网表面积")<br />                ))<br /> <br /> <br /> <br />   <br />   (princ (strcat (rtos (+ i 1) 2 0)","(rtos demj 2 3) "," (rtos (38zu ent) 2 3) "\n"<br />     ) ff)<br /> <br /> <br />   <br />   <br />   <br /> ;(setq zmj(+ zmj demj))<br /> <br /> (setq i (+ i 1))<br />   <br />   <br />   )<br /> <br /> (close ff)<br />   (princ)<br /> <br /> )

yoyoho

感谢分享程序!!!!!

longer1000

感谢分享程序!!!!!

树櫴希德

1. (mapcar 'cdr (vl-remove-if-not  '(LAMBDA (A1)(equal 10 (car a1)) )  (entget (car(entsel)))) )

(mapcar 'cdr (vl-remove-if-not  '(LAMBDA (A1)(equal 10 (car a1)) )  (entget (car(entsel)))) )