求助，能一次性生成大量闭合多段线面积的插件，急用。

zxjing

要收费的人就不要回帖了。生成的面积精度：小数点保留2位以上

gufeng

你要生成的面积是保存在文件，还是显示在图面，还是显示到命令行？

429014673

我也想要一个   工作而要   最好是生成表格的   没有的话最好显示在图中的也好

luowy

1，选择所有的pline

2，移出不闭合的pline

3，找出顶点及顶点的数量，并求出顶点的算术平均点

4，找出面积，写面积

429014673

扬起

xyp1964

zxjing

gufeng发表于2010-7-8 10:53:00你要生成的面积是保存在文件，还是显示在图面，还是显示到命令行？

目前来说最好是显示在图上~~

429014673

强烈关注

zxjing

2. (defun C:am (/ ss l i totalarea ename obj entarea)
3. (if (setq ss (ssget))
4. (progn
5. (vl-load-com)
6. (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))
7. (setq l (sslength ss) i 0 totalarea 0 totlength 0)
8. (repeat l
9. (setq ename (ssname ss i))
10. (setq obj (vlax-ename->vla-object ename))
11.     ;;(vlax-dump-object obj T)
12.     (if (vlax-property-available-p obj "area")
13. (setq totalarea (+ (vlax-get-property obj 'area) totalarea))
14. )
15.     (if (= (cdr (assoc 0 (entget ename))) "MLINE")
16.      (setq totlength (+ totlength (ml-length ename)))
17.      (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))
18.     )
19. (setq i (1+ i))
20. )
21. (setq text1 (strcat "总面积为: " (rtos totalarea 2 4) "平方毫米")
22.      text2 (strcat "长度为: " (rtos totlength 2 4) "米")
23. )
24. (if (setq insertpt (getpoint "\n请输入文字插入点: "))
25.     (if (setq height (getdist "\n请输入文字高度:"))
26.      (setq insertp1 (vlax-3d-point insertpt)
27.         insertp2 (vlax-3d-point (polar insertpt (* 1.5 Pi) (* 1.5 height)))
28.      textobj1 (vla-addtext modelspace text1 insertp1 height)
29.         textobj2 (vla-addtext modelspace text2 insertp2 height)
30.      )
31.     )
32. )
33. )
34. )
35. )
36. (defun ml-length (ename / j d ptlist)
37. (foreach n (entget ename)
38. (if (= (car n) 11)
39. (setq ptlist (cons (cdr n) ptlist))
40. )
41. )
42. (reverse ptlist)
43. (setq j 0 d 0)
44. (repeat (1- (length ptlist))
45. (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist))))
46. (setq j (1+ j))
47. )
48. d
49. )

(defun C:am (/ ss l i totalarea ename obj entarea) (if (setq ss (ssget)) (progn (vl-load-com) (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object)))) (setq l (sslength ss) i 0 totalarea 0 totlength 0) (repeat l (setq ename (ssname ss i)) (setq obj (vlax-ename->vla-object ename))     ;;(vlax-dump-object obj T)     (if (vlax-property-available-p obj "area") (setq totalarea (+ (vlax-get-property obj 'area) totalarea)) )     (if (= (cdr (assoc 0 (entget ename))) "MLINE")      (setq totlength (+ totlength (ml-length ename)))      (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))     ) (setq i (1+ i)) ) (setq text1 (strcat "总面积为: " (rtos totalarea 2 4) "平方毫米")      text2 (strcat "长度为: " (rtos totlength 2 4) "米") ) (if (setq insertpt (getpoint "\n请输入文字插入点: "))     (if (setq height (getdist "\n请输入文字高度:"))      (setq insertp1 (vlax-3d-point insertpt)         insertp2 (vlax-3d-point (polar insertpt (* 1.5 Pi) (* 1.5 height)))      textobj1 (vla-addtext modelspace text1 insertp1 height)         textobj2 (vla-addtext modelspace text2 insertp2 height)      )     ) ) ) ) ) (defun ml-length (ename / j d ptlist) (foreach n (entget ename) (if (= (car n) 11) (setq ptlist (cons (cdr n) ptlist)) ) ) (reverse ptlist) (setq j 0 d 0) (repeat (1- (length ptlist)) (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist)))) (setq j (1+ j)) ) d )

zxjing

2. ;;;程序功能: 面积计算及求和
3. ;;;程序编制人: 查克
4. ;;;程序名称: MJ.LSP
5. ;;;编制时间: 1995 中山老干部活动中心
6. ;;;修改时间: 1995.11.30 厦门武警水电大楼
7. ;;;命令名称:
8. ;;; MT: 参数设置, P 输入人均指标； U 面积计算结果以公顷为单位；F 打
9. ;;;　 　　　　　　　印结果时在前面加层名, A 在上方标注层名; T 　输入标注字高,
10. ;;; D 小数点位数
11. ;;; MD 取消上述参数设置
12. ;;; TT : 按层求和, 求某层所有数字总和
13. ;;; TY : 点选求和, 只计算用鼠标所选择的数字之和
14. ;;; TR : 框选求和, 计算选择框内所有数字之和, 可多次选择
15. ;;; ML: 计算面积, 按层计算，输入层名称后，计算该层所有 PLINE 线的
16. ;;; 面积之和
17. ;;; MM: 计算面积, 计算选择框内所有 PLINE 线面积之和, 可多次选择
18. ;;; MC: 计算面积, 按颜色计算，输入颜色名（代号）后，计算以该颜色画
19. ;;; 的所有 PLINE 线的面积之和，BYLAYER 或 BYBLOCK 的颜色
20. ;;; 不能以这种方式计算。
21. ;;; MJ: 计算面积，用鼠标单选 PLINE 线计算。
22. ;;; NN: 以用地面积推算各地块的人口，计算前先用MT命令输入人均用地
23. ;;; 面积指标。
24. (defun c:mt () ;;; 参数设置 PLINE PLINE
25. (setq cs1 nil cs2 nil cs3 nil)
26. (setq cs (getstring"\nP 人口计算/U 单位/L 标注层名/H 字高/D 小数点位数 "))
27. (if (or (= cs "d")(= cs "D"))
28. (setq csd (getint "Input the Number of desimal ")))
29. (if (= csd nil)(setq csd 2))
30. (if (or (= cs "h") (= cs "H"))
31. (setq cst (getreal"Input text high, Please ")))
32. (if (= cst nil )
33. (setq cst 50))
34. (if (or (= cs "u") (= cs "U"))
35. (setq ck1 1))
36. (if (or (= cs "p") (= cs "P"))
37. (setq csp (getreal"\n请输入人均用地指标：")))
38. (if (or (= cs "l") (= cs "L"))
39. (setq cslay (getstring"\nput layaer name Above or Front? ")))
40. )
41. (defun c:md ()
42. ;;; 参数设置 PLINE PLINE
43. (setq cs1 nil cs2 nil cs3 nil)
44. (setq cs (getstring"\nUnit/Layer name/text-High "))
45. (if (or (= cs "t") (= cs "T"))
46. (setq cst 50))
47. (if (or (= cs "u") (= cs "U"))
48. (setq ck1 21))
49. (if (or (= cs "l") (= cs "L"))
50. (setq cs3 (getstring"\nput layaer name Above or Front? ")))
51. (if (or (= cs3 "f") (= cs3 "F"))
52. (setq ck1 13))
53. (if (or (= cs3 "a") (= cs3 "A"))
54. (setq ck1 14))
55. )
56. (DEFUN C:tt()
57. ;统计,计算某一层的所有数字总和
58. (setq aa nil)
59. (setq tnumb 0)
60. (setq ltnm (getstring"\nPlease Input the Layer Name : "))
61. (SETQ Aa (SSGET "x" (list (cons 0 "text")
62. (cons 8 ltnm)
63. ) ) )
64. (jsss)
65. )
66. (defun c:ty () ;;;框选求和
67. (setq aa nil tnumb 0)
68. (setq aa (ssget))
69. (jsss)
70. )
71. (defun c:tr () ;;; 框选求和2
72. (setq aa nil)
73. (setq tnumb 0)
74. (setq aa (ssget "x" (list (cons 0 "text"))))
75. (jsss)
76. )
77. (defun jsss()
78. (if (= csd nil)
79. (setq csd 2))
80. (if (or (= cst nil)(= cst 0))
81. (setq cst 50))
82. (SETQ www (SSNAME aA 0))
83. (SETQ TNUMB (SSLENGTH Aa))
84. (SETQ YDMJ 0.0 JZMJ 0.0 ZZMJ 0.0)
85. (SETQ TTTT 0)
86. (WHILE www
87. (SETQ TNM (ENTGET www))
88. (SETQ P0 (CDR (ASSOC 10 TNM)))
89. (SETQ TPX (CAR P0))
90. (SETQ TPY (CAR (CDR P0)))
91. (SETQ TEEX (CDR (ASSOC 1 TNM)))
92. (SETQ TDATE (ATOF TEEX))
93. (SETQ YDMJ (+ YDMJ TDATE))
94. (setq tttt (+ tttt 1))
95. (setq www (ssname aa tttt)) )
96. (setq rk (rtos ydmj 2 csd))
97. (SETQ PO (getpoint "\nInput the Start Place for TEXT, PLease "))
98. (COMMAND "TEXT" PO cst 0 rk))
99. (defun c:ml ()
100. (SETQ LNM (GETSTRING "\Input the Layer Name, Please : "))
101. (setq m (ssget "x" (list (cons -4 "<or")
102. (cons 0 "POLYLINE")
103. (cons 0 "LWPOLYLINE")
104. (cons -4 "or>")
105. (cons 8 lnm)) ))
106. (MJJS))
107. (DEFUN C:mc ()
108. (SETQ cnm (GETint "\nPlease Input Color number :"))
109. (setq m (ssget "x" (list (cons -4 "<or")
110. (cons 0 "polyline")
111. (cons 0 "lwpolyline")
112. (cons -4 "or>")
113. (cons 62 cnm) ) ))
114. (mjjs))
115. (DEFUN C:mm () ;;;框选 PLINE 线计算面积
116. (SETQ M (SSGET))
117. (MJJS))
118. (DEFUN MJJS ()
119. (if (= csd nil)
120. (setq csd 2))
121. (if (or (= cst nil)(= cst 0))
122. (setq cst 50))
123. (setq uu (ssname m 0))
124. (setq nn (sslength m))
125. (setq tmj 0 smj 0)
126. (setq t 0 nnn 0)
127. (while nnn
128. (command "area" "e" uu)
129. (setq ssmj (list (getvar "area")))
130. (setq smj (car ssmj))
131. (setq tmj (+ tmj smj))
132. (setq t (+ t 1))
133. (setq uu (ssname m t))
134. (if (= t nn) (setq nnn nil))
135. )
136. (if (= ck1 1)
137. (setq tmmj (rtos (/ tmj 10000) 2 csd ) )
138. (setq tmmj (rtos tmj 2 csd))
139. )
140. (SETVAR "OSMODE" 32)
141. (setq po (getpoint "\n请输入标注点位置 : "))
142. (if (/= cslay nil)
143. (lmmjs)
144. (mmmm) ))
145. (defun mmmm ()
146. (command "text" po cst 0 tmmj)
147. )
148. (defun lmmjs ()
149. (if (or (= cslay "f")(= cslay "F"))
150. (progn (setq klj (atoi tmmj))
151. (setq kljj (itoa klj))
152. (setq lllkkk (strlen kljj))
153. (setq csl (* (- 15 lllkkk) cst 0.712092))
154. (setq p1 (polar po 0 csl)))
155. (progn (setq a1 (- 0 (/ pi 2)))
156. (setq p1 (polar po a1 100)) ))
157. (setq rrrhhh (strcase lnm))
158. (SETVAR "OSMODE" 0)
159. (command "text" po cst 0 rrrhhh)
160. (command "text" p1 cst 0 tmmj))
161. (defun c:mj ()
162. ;;;计算 PLINE 线面积, 单选, 以公顷为单位, 标注层名
163. (if (= csd nil)(setq csd 2))
164. (setq plnm (car (setq plnm1 (entsel"Select a Polyline, Please: "))))
165. (setq plnmm (entget plnm))
166. (setq lnm (cdr (assoc 8 plnmm )))
167. (command "area" "e" plnm)
168. (setq ssmj (car list (getvar "area"))))
169. (if (= ck1 1)
170. (setq tmmj (rtos (/ ssmj 10000) 2 csd))
171. (setq tmmj (rtos ssmj 2 csd)))
172. (setq po (getpoint "\nInput the Text Start Point Place,
173. Please : "))
174. (if (/= cslay nil)
175. (lmmjs)
176. (mmmm)
177. )
178. )
179. (defun c:nn ()
180. ;;;用人均用地指标计算人口
181. (setq plnm (car (setq plnm1 (entsel"Select a Polyline, Please: "))))
182. (princ "面积")
183. (setq plnmm (entget plnm))
184. (setq lnmtext (cdr (assoc 8 plnmm )))
185. (command "area" "e" plnm)
186. (setq ssmj (car (list (getvar "area"))))
187. (setq plmj (rtos (/ ssmj csp) 2 0))
188. (setq p0 (getpoint"Please give a point for Text: "))
189. (command "text" p0 cst 0 plmj)
190. )

;;;程序功能: 面积计算及求和 ;;;程序编制人: 查克 ;;;程序名称: MJ.LSP ;;;编制时间: 1995 中山老干部活动中心 ;;;修改时间: 1995.11.30 厦门武警水电大楼 ;;;命令名称: ;;; MT: 参数设置, P 输入人均指标； U 面积计算结果以公顷为单位；F 打 ;;;　 　　　　　　　印结果时在前面加层名, A 在上方标注层名; T 　输入标注字高, ;;; D 小数点位数 ;;; MD 取消上述参数设置 ;;; TT : 按层求和, 求某层所有数字总和 ;;; TY : 点选求和, 只计算用鼠标所选择的数字之和 ;;; TR : 框选求和, 计算选择框内所有数字之和, 可多次选择 ;;; ML: 计算面积, 按层计算，输入层名称后，计算该层所有 PLINE 线的 ;;; 面积之和 ;;; MM: 计算面积, 计算选择框内所有 PLINE 线面积之和, 可多次选择 ;;; MC: 计算面积, 按颜色计算，输入颜色名（代号）后，计算以该颜色画 ;;; 的所有 PLINE 线的面积之和，BYLAYER 或 BYBLOCK 的颜色 ;;; 不能以这种方式计算。 ;;; MJ: 计算面积，用鼠标单选 PLINE 线计算。 ;;; NN: 以用地面积推算各地块的人口，计算前先用MT命令输入人均用地 ;;; 面积指标。 (defun c:mt () ;;; 参数设置 PLINE PLINE (setq cs1 nil cs2 nil cs3 nil) (setq cs (getstring"\nP 人口计算/U 单位/L 标注层名/H 字高/D 小数点位数 ")) (if (or (= cs "d")(= cs "D")) (setq csd (getint "Input the Number of desimal "))) (if (= csd nil)(setq csd 2)) (if (or (= cs "h") (= cs "H")) (setq cst (getreal"Input text high, Please "))) (if (= cst nil ) (setq cst 50)) (if (or (= cs "u") (= cs "U")) (setq ck1 1)) (if (or (= cs "p") (= cs "P")) (setq csp (getreal"\n请输入人均用地指标："))) (if (or (= cs "l") (= cs "L")) (setq cslay (getstring"\nput layaer name Above or Front? "))) ) (defun c:md () ;;; 参数设置 PLINE PLINE (setq cs1 nil cs2 nil cs3 nil) (setq cs (getstring"\nUnit/Layer name/text-High ")) (if (or (= cs "t") (= cs "T")) (setq cst 50)) (if (or (= cs "u") (= cs "U")) (setq ck1 21)) (if (or (= cs "l") (= cs "L")) (setq cs3 (getstring"\nput layaer name Above or Front? "))) (if (or (= cs3 "f") (= cs3 "F")) (setq ck1 13)) (if (or (= cs3 "a") (= cs3 "A")) (setq ck1 14)) ) (DEFUN C:tt() ;统计,计算某一层的所有数字总和 (setq aa nil) (setq tnumb 0) (setq ltnm (getstring"\nPlease Input the Layer Name : ")) (SETQ Aa (SSGET "x" (list (cons 0 "text") (cons 8 ltnm) ) ) ) (jsss) ) (defun c:ty () ;;;框选求和 (setq aa nil tnumb 0) (setq aa (ssget)) (jsss) ) (defun c:tr () ;;; 框选求和2 (setq aa nil) (setq tnumb 0) (setq aa (ssget "x" (list (cons 0 "text")))) (jsss) ) (defun jsss() (if (= csd nil) (setq csd 2)) (if (or (= cst nil)(= cst 0)) (setq cst 50)) (SETQ www (SSNAME aA 0)) (SETQ TNUMB (SSLENGTH Aa)) (SETQ YDMJ 0.0 JZMJ 0.0 ZZMJ 0.0) (SETQ TTTT 0) (WHILE www (SETQ TNM (ENTGET www)) (SETQ P0 (CDR (ASSOC 10 TNM))) (SETQ TPX (CAR P0)) (SETQ TPY (CAR (CDR P0))) (SETQ TEEX (CDR (ASSOC 1 TNM))) (SETQ TDATE (ATOF TEEX)) (SETQ YDMJ (+ YDMJ TDATE)) (setq tttt (+ tttt 1)) (setq www (ssname aa tttt)) ) (setq rk (rtos ydmj 2 csd)) (SETQ PO (getpoint "\nInput the Start Place for TEXT, PLease ")) (COMMAND "TEXT" PO cst 0 rk)) (defun c:ml () (SETQ LNM (GETSTRING "\Input the Layer Name, Please : ")) (setq m (ssget "x" (list (cons -4 "<or") (cons 0 "POLYLINE") (cons 0 "LWPOLYLINE") (cons -4 "or>") (cons 8 lnm)) )) (MJJS)) (DEFUN C:mc () (SETQ cnm (GETint "\nPlease Input Color number :")) (setq m (ssget "x" (list (cons -4 "<or") (cons 0 "polyline") (cons 0 "lwpolyline") (cons -4 "or>") (cons 62 cnm) ) )) (mjjs)) (DEFUN C:mm () ;;;框选 PLINE 线计算面积 (SETQ M (SSGET)) (MJJS)) (DEFUN MJJS () (if (= csd nil) (setq csd 2)) (if (or (= cst nil)(= cst 0)) (setq cst 50)) (setq uu (ssname m 0)) (setq nn (sslength m)) (setq tmj 0 smj 0) (setq t 0 nnn 0) (while nnn (command "area" "e" uu) (setq ssmj (list (getvar "area"))) (setq smj (car ssmj)) (setq tmj (+ tmj smj)) (setq t (+ t 1)) (setq uu (ssname m t)) (if (= t nn) (setq nnn nil)) ) (if (= ck1 1) (setq tmmj (rtos (/ tmj 10000) 2 csd ) ) (setq tmmj (rtos tmj 2 csd)) ) (SETVAR "OSMODE" 32) (setq po (getpoint "\n请输入标注点位置 : ")) (if (/= cslay nil) (lmmjs) (mmmm) )) (defun mmmm () (command "text" po cst 0 tmmj) ) (defun lmmjs () (if (or (= cslay "f")(= cslay "F")) (progn (setq klj (atoi tmmj)) (setq kljj (itoa klj)) (setq lllkkk (strlen kljj)) (setq csl (* (- 15 lllkkk) cst 0.712092)) (setq p1 (polar po 0 csl))) (progn (setq a1 (- 0 (/ pi 2))) (setq p1 (polar po a1 100)) )) (setq rrrhhh (strcase lnm)) (SETVAR "OSMODE" 0) (command "text" po cst 0 rrrhhh) (command "text" p1 cst 0 tmmj)) (defun c:mj () ;;;计算 PLINE 线面积, 单选, 以公顷为单位, 标注层名 (if (= csd nil)(setq csd 2)) (setq plnm (car (setq plnm1 (entsel"Select a Polyline, Please: ")))) (setq plnmm (entget plnm)) (setq lnm (cdr (assoc 8 plnmm ))) (command "area" "e" plnm) (setq ssmj (car list (getvar "area")))) (if (= ck1 1) (setq tmmj (rtos (/ ssmj 10000) 2 csd)) (setq tmmj (rtos ssmj 2 csd))) (setq po (getpoint "\nInput the Text Start Point Place, Please : ")) (if (/= cslay nil) (lmmjs) (mmmm) ) ) (defun c:nn () ;;;用人均用地指标计算人口 (setq plnm (car (setq plnm1 (entsel"Select a Polyline, Please: ")))) (princ "面积") (setq plnmm (entget plnm)) (setq lnmtext (cdr (assoc 8 plnmm ))) (command "area" "e" plnm) (setq ssmj (car (list (getvar "area")))) (setq plmj (rtos (/ ssmj csp) 2 0)) (setq p0 (getpoint"Please give a point for Text: ")) (command "text" p0 cst 0 plmj) )