请帮忙修改下，谢谢！

lucas_3333

高飞鸟大师的源码

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

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

高飞版主的代码是将结果插入到文档中的，我想能不能用下面的的方式，即弹出结果？

2. ;;;调用vb输入框 by Xran
   
3. ;;;promptstr 提示信息
   
4. ;;;title 窗体标题栏信息
   
5. ;;;default 缺省值
   
6. (defun inputbox (promptstr title default)
   
7.   (vla-eval (vlax-get-acad-object)
   
8.       (strcat "ThisDrawing.setVariable "USERS5",inputBox (""
   
9.         promptstr
   
10.         "", ""
    
11.         title
    
12.         "", ""
    
13.         default
    
14.         "")"
    
15.        )
    
16.   )
    
17.   (getvar "users5")
    
18. )

;;;调用vb输入框 by Xran<br /> ;;;promptstr 提示信息<br /> ;;;title 窗体标题栏信息<br /> ;;;default 缺省值<br /> (defun inputbox (promptstr title default)<br />   (vla-eval (vlax-get-acad-object)<br />       (strcat "ThisDrawing.setVariable "USERS5",inputBox (""<br />         promptstr<br />         "", ""<br />         title<br />         "", ""<br />         default<br />         "")"<br />        )<br />   )<br />   (getvar "users5")<br /> )

edata

注意单位是米

1. (defun C:am (/ ss l i totalarea ename obj entarea)
   
2.   (if (setq ss (ssget'((0 . "*line,arc,circle,ellipse"))))
   
3.     (progn
   
4.       (vl-load-com)
   
5.       (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))
   
6.       (setq l (sslength ss) i 0 totalarea 0 totlength 0)
   
7.       (repeat l
   
8.         (setq ename (ssname ss i))
   
9.         (setq obj (vlax-ename->vla-object ename))
   
10.         (if (vlax-property-available-p obj "area")
    
11.           (setq totalarea (+ (vlax-get-property obj 'area) totalarea))
    
12.           )
    
13.         (if (= (cdr (assoc 0 (entget ename))) "MLINE")
    
14.           (setq totlength (+ totlength (ml-length ename)))
    
15.           (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))
    
16.           )
    
17.         (setq i (1+ i))
    
18.         )
    
19. ;;;      (setq text1 (strcat "总面积为: " (rtos totalarea 2 4) "平方单位")
    
20. ;;;     text2 (strcat "总长度为: " (rtos totlength 2 4) "单位")
    
21. ;;;      )
    
22.       ;(inputbox  "总面积为<平方单位>: "  "统计" (rtos totalarea 2 4))
    
23.       (inputbox  "总面积为<平方米>: "  "统计"  (rtos (* totalarea 0.000001) 2 4))
    
24.       ;(inputbox  "总长度为<单位>: "  "统计" (rtos totlength 2 4))
    
25.       (inputbox  "总长度为<米>: "  "统计" (rtos (* totlength 0.001) 2 4))
    
26. ;;;      (if (setq insertpt (getpoint "\n请输入文字插入点: "))
    
27. ;;;(if (setq height (getdist "\n请输入文字高度:"))
    
28. ;;;   (setq insertp1 (vlax-3d-point insertpt)
    
29. ;;;  insertp2 (vlax-3d-point (polar insertpt (* 1.5 Pi) (* 1.5 height)))
    
30. ;;;         textobj1 (vla-addtext modelspace text1 insertp1 height)
    
31. ;;;  textobj2 (vla-addtext modelspace text2 insertp2 height)
    
32. ;;;   )
    
33. ;;;)
    
34. ;;;      )
    
35.     )
    
36.   )
    
37. )
    
38. (defun ml-length (ename / j d ptlist)
    
39.   (foreach n (entget ename)
    
40.     (if (= (car n) 11)
    
41.       (setq ptlist (cons (cdr n) ptlist))
    
42.     )
    
43.   )
    
44.   (reverse ptlist)
    
45.   (setq j 0 d 0)
    
46.   (repeat (1- (length ptlist))
    
47.     (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist))))
    
48.     (setq j (1+ j))
    
49.   )
    
50.   d
    
51. )
    
52. ;;;调用vb输入框 by Xran
    
53. ;;;promptstr 提示信息
    
54. ;;;title 窗体标题栏信息
    
55. ;;;default 缺省值
    
56. (defun inputbox (promptstr title default)
    
57.   (vla-eval (vlax-get-acad-object)
    
58.       (strcat "ThisDrawing.setVariable \"USERS5\",inputBox (\""
    
59.         promptstr
    
60.         "\", \""
    
61.         title
    
62.         "\", \""
    
63.         default
    
64.         "\")"
    
65.        )
    
66.   )
    
67.   (getvar "users5")
    
68. )

(defun C:am (/ ss l i totalarea ename obj entarea)<br />   (if (setq ss (ssget'((0 . "*line,arc,circle,ellipse"))))<br />     (progn<br />       (vl-load-com)<br />       (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))<br />       (setq l (sslength ss) i 0 totalarea 0 totlength 0)<br />       (repeat l<br />         (setq ename (ssname ss i))<br />         (setq obj (vlax-ename->vla-object ename))<br />         (if (vlax-property-available-p obj "area")<br />           (setq totalarea (+ (vlax-get-property obj 'area) totalarea))<br />           )<br />         (if (= (cdr (assoc 0 (entget ename))) "MLINE")<br />           (setq totlength (+ totlength (ml-length ename)))<br />           (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))<br />           )<br />         (setq i (1+ i))<br />         )<br /> ;;;      (setq text1 (strcat "总面积为: " (rtos totalarea 2 4) "平方单位")<br /> ;;;     text2 (strcat "总长度为: " (rtos totlength 2 4) "单位")<br /> ;;;      )<br />       ;(inputbox  "总面积为<平方单位>: "  "统计" (rtos totalarea 2 4))<br />       (inputbox  "总面积为<平方米>: "  "统计"  (rtos (* totalarea 0.000001) 2 4))<br />       ;(inputbox  "总长度为<单位>: "  "统计" (rtos totlength 2 4))<br />       (inputbox  "总长度为<米>: "  "统计" (rtos (* totlength 0.001) 2 4))<br /> ;;;      (if (setq insertpt (getpoint "\n请输入文字插入点: "))<br /> ;;;(if (setq height (getdist "\n请输入文字高度:"))<br /> ;;;   (setq insertp1 (vlax-3d-point insertpt)<br /> ;;;  insertp2 (vlax-3d-point (polar insertpt (* 1.5 Pi) (* 1.5 height)))<br /> ;;;         textobj1 (vla-addtext modelspace text1 insertp1 height)<br /> ;;;  textobj2 (vla-addtext modelspace text2 insertp2 height)<br /> ;;;   )<br /> ;;;)<br /> ;;;      )<br />     )<br />   )<br /> )<br /> (defun ml-length (ename / j d ptlist)<br />   (foreach n (entget ename)<br />     (if (= (car n) 11)<br />       (setq ptlist (cons (cdr n) ptlist))<br />     )<br />   )<br />   (reverse ptlist)<br />   (setq j 0 d 0)<br />   (repeat (1- (length ptlist))<br />     (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist))))<br />     (setq j (1+ j))<br />   )<br />   d<br /> )<br /> ;;;调用vb输入框 by Xran<br /> ;;;promptstr 提示信息<br /> ;;;title 窗体标题栏信息<br /> ;;;default 缺省值<br /> (defun inputbox (promptstr title default)<br />   (vla-eval (vlax-get-acad-object)<br />       (strcat "ThisDrawing.setVariable \"USERS5\",inputBox (\""<br />         promptstr<br />         "\", \""<br />         title<br />         "\", \""<br />         default<br />         "\")"<br />        )<br />   )<br />   (getvar "users5")<br /> )

lucas_3333

edata 发表于 2014-6-3 15:00
注意单位是米

谢谢Ｅ大，可是出错了
Select objects: Specify opposite corner: 9 found
Select objects:  ; error: Automation Error.

另外我想长度以毫米为单位

edata

1. (defun C:am (/ ss l i totalarea ename obj entarea)
   
2.   (if (setq ss (ssget'((0 . "*line,arc,circle,ellipse"))))
   
3.     (progn
   
4.       (vl-load-com)
   
5.       (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))
   
6.       (setq l (sslength ss) i 0 totalarea 0 totlength 0)
   
7.       (repeat l
   
8.         (setq ename (ssname ss i))
   
9.         (setq obj (vlax-ename->vla-object ename))
   
10.         (if (vlax-property-available-p obj "area")
    
11.           (setq totalarea (+ (vlax-get-property obj 'area) totalarea))
    
12.           )
    
13.         (if (= (cdr (assoc 0 (entget ename))) "MLINE")
    
14.           (setq totlength (+ totlength (ml-length ename)))
    
15.           (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))
    
16.           )
    
17.         (setq i (1+ i))
    
18.         )
    
19.       (inputbox  "总面积为<平方米>: "  "统计"  (rtos (* totalarea 0.000001) 2 4))      
    
20.       (inputbox  "总长度为<毫米>: "  "统计" (rtos totlength 2 4))
    
21.     )
    
22.   )
    
23. )
    
24. (defun ml-length (ename / j d ptlist)
    
25.   (foreach n (entget ename)
    
26.     (if (= (car n) 11)
    
27.       (setq ptlist (cons (cdr n) ptlist))
    
28.     )
    
29.   )
    
30.   (reverse ptlist)
    
31.   (setq j 0 d 0)
    
32.   (repeat (1- (length ptlist))
    
33.     (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist))))
    
34.     (setq j (1+ j))
    
35.   )
    
36.   d
    
37. )
    
38. ;;;调用vb输入框 by Xran
    
39. ;;;promptstr 提示信息
    
40. ;;;title 窗体标题栏信息
    
41. ;;;default 缺省值
    
42. (defun inputbox (promptstr title default)
    
43.   (vla-eval (vlax-get-acad-object)
    
44.       (strcat "ThisDrawing.setVariable \"USERS5\",inputBox (\""
    
45.         promptstr
    
46.         "\", \""
    
47.         title
    
48.         "\", \""
    
49.         default
    
50.         "\")"
    
51.        )
    
52.   )
    
53.   (getvar "users5")
    
54. )

(defun C:am (/ ss l i totalarea ename obj entarea)<br />   (if (setq ss (ssget'((0 . "*line,arc,circle,ellipse"))))<br />     (progn<br />       (vl-load-com)<br />       (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))<br />       (setq l (sslength ss) i 0 totalarea 0 totlength 0)<br />       (repeat l<br />         (setq ename (ssname ss i))<br />         (setq obj (vlax-ename->vla-object ename))<br />         (if (vlax-property-available-p obj "area")<br />           (setq totalarea (+ (vlax-get-property obj 'area) totalarea))<br />           )<br />         (if (= (cdr (assoc 0 (entget ename))) "MLINE")<br />           (setq totlength (+ totlength (ml-length ename)))<br />           (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))<br />           )<br />         (setq i (1+ i))<br />         )<br />       (inputbox  "总面积为<平方米>: "  "统计"  (rtos (* totalarea 0.000001) 2 4))      <br />       (inputbox  "总长度为<毫米>: "  "统计" (rtos totlength 2 4))<br />     )<br />   )<br /> )<br /> (defun ml-length (ename / j d ptlist)<br />   (foreach n (entget ename)<br />     (if (= (car n) 11)<br />       (setq ptlist (cons (cdr n) ptlist))<br />     )<br />   )<br />   (reverse ptlist)<br />   (setq j 0 d 0)<br />   (repeat (1- (length ptlist))<br />     (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist))))<br />     (setq j (1+ j))<br />   )<br />   d<br /> )<br /> ;;;调用vb输入框 by Xran<br /> ;;;promptstr 提示信息<br /> ;;;title 窗体标题栏信息<br /> ;;;default 缺省值<br /> (defun inputbox (promptstr title default)<br />   (vla-eval (vlax-get-acad-object)<br />       (strcat "ThisDrawing.setVariable \"USERS5\",inputBox (\""<br />         promptstr<br />         "\", \""<br />         title<br />         "\", \""<br />         default<br />         "\")"<br />        )<br />   )<br />   (getvar "users5")<br /> )

lucas_3333

edata 发表于 2014-6-3 16:15

刚才没有装ＶＢＡ,现在装了ＶＢＡ工作正常，谢谢Ｅ大

edata

1. (defun C:am (/ ss l i totalarea ename obj entarea)
   
2.   (if (setq ss (ssget'((0 . "*line,arc,circle,ellipse"))))
   
3.     (progn
   
4.       (vl-load-com)
   
5.       (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))
   
6.       (setq l (sslength ss) i 0 totalarea 0 totlength 0)
   
7.       (repeat l
   
8.         (setq ename (ssname ss i))
   
9.         (setq obj (vlax-ename->vla-object ename))
   
10.         (if (vlax-property-available-p obj "area")
    
11.           (setq totalarea (+ (vlax-get-property obj 'area) totalarea))
    
12.           )
    
13.         (if (= (cdr (assoc 0 (entget ename))) "MLINE")
    
14.           (setq totlength (+ totlength (ml-length ename)))
    
15.           (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))
    
16.           )
    
17.         (setq i (1+ i))
    
18.         )
    
19.       (setq text1 (strcat "总面积为(平方单位): " (rtos totalarea 2 4) )
    
20.             text2 (strcat "总长度为(单位): " (rtos totlength 2 4) )
    
21.       )
    
22.       (alert (strcat text1 "\n" text2))
    
23.       (princ "\n")(princ text1)(princ "\n")(princ text2)
    
24.       
    
25.     )
    
26.   )
    
27.   (princ)
    
28. )
    
29. (defun ml-length (ename / j d ptlist)
    
30.   (foreach n (entget ename)
    
31.     (if (= (car n) 11)
    
32.       (setq ptlist (cons (cdr n) ptlist))
    
33.     )
    
34.   )
    
35.   (reverse ptlist)
    
36.   (setq j 0 d 0)
    
37.   (repeat (1- (length ptlist))
    
38.     (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist))))
    
39.     (setq j (1+ j))
    
40.   )
    
41.   d
    
42. )
    

(defun C:am (/ ss l i totalarea ename obj entarea)<br />   (if (setq ss (ssget'((0 . "*line,arc,circle,ellipse"))))<br />     (progn<br />       (vl-load-com)<br />       (setq modelspace (vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))<br />       (setq l (sslength ss) i 0 totalarea 0 totlength 0)<br />       (repeat l<br />         (setq ename (ssname ss i))<br />         (setq obj (vlax-ename->vla-object ename))<br />         (if (vlax-property-available-p obj "area")<br />           (setq totalarea (+ (vlax-get-property obj 'area) totalarea))<br />           )<br />         (if (= (cdr (assoc 0 (entget ename))) "MLINE")<br />           (setq totlength (+ totlength (ml-length ename)))<br />           (setq totlength (+ totlength (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename))))<br />           )<br />         (setq i (1+ i))<br />         )<br />       (setq text1 (strcat "总面积为(平方单位): " (rtos totalarea 2 4) )<br />             text2 (strcat "总长度为(单位): " (rtos totlength 2 4) )<br />       )<br />       (alert (strcat text1 "\n" text2))<br />       (princ "\n")(princ text1)(princ "\n")(princ text2)<br />       <br />     )<br />   )<br />   (princ)<br /> )<br /> (defun ml-length (ename / j d ptlist)<br />   (foreach n (entget ename)<br />     (if (= (car n) 11)<br />       (setq ptlist (cons (cdr n) ptlist))<br />     )<br />   )<br />   (reverse ptlist)<br />   (setq j 0 d 0)<br />   (repeat (1- (length ptlist))<br />     (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist))))<br />     (setq j (1+ j))<br />   )<br />   d<br /> )<br />