[LISP程序]：面积输出的代码

钝刀

本人编写的面积输出的代码供大家分享
刚才发错论坛了

2. 
   
3. ; ga.Lsp
   
4. ; 面积输出
   
5. ; Auguest 29th 2001
   
6. 
   
7. ; ent ent_data ent_lay_new ent_lay_name ent_list ent_list_len
   
8. ; id ent_lay_old ent_data_new msg1 msg2
   
9. 
   
10. (defun c:llsp()
    
11.   (load "ga")
    
12. )
    
13. 
    
14. (defun c:ga(/ orig_blip orig_cmd put_out file_name file_id
    
15.               A1 p2 p1x p1y p2x p2 ent_data_new msg1 msg2)
    
16.   (vl-load-com)
    
17.   (setq acadObject (vlax-get-acad-object))
    
18.   (setq acadDocument (vla-get-Activedocument acadObject))
    
19.   (setq mSpace (vla-get-ModelSpace acadDocument))
    
20.   
    
21.   (setq orig_blip (getvar "blipmode"))
    
22.   (setq orig_cmd (getvar "cmdecho"))
    
23.   (setvar "blipmode" 0 )
    
24.   (setvar "cmdecho" 1 )
    
25.   (setvar "osmode" 32)
    
26.   
    
27.   (setq put_out "Area-1")
    
28.   (setq file_name (getfiled "请指定要输出文件的名称" put_out "txt" 1))
    
29.   (setq file_id (open file_name "w"))
    
30. 
    
31.   (prompt "\n 请选取要输出的面域： ")
    
32.   (setq ent_list (ssget :s))
    
33.   ;(setq ent_list_len (sslength ent_list))
    
34.   (setq ent_data (entget (ssname ent_list 0)))
    
35.   (setq Area_cad_id (cdr (assoc -1 ent_data)))
    
36. ;(setq Area_cad_id (car ent_data))
    
37. ;(setq Area_cad_id (car (ssget "\n 请选取要输出的面域")))
    
38.   (setq A_id (vlax-ename->vla-object Area_cad_id))
    
39.   (setq aa1 (vla-get-Area A_id))
    
40.   (setq aa2 (rtos aa1 2))
    
41.   (setq pt (getpoint "\n 请输入文本的起始点："))
    
42.   (setq pt1 (getpoint "\n 请输入标注点："))
    
43.   (command "line" pt pt1 "")
    
44.   (command "text" "bc" pt 3.0 0 aa2)
    
45.   (setq n 0)
    
46.   
    
47. (princ "序号 " file_id) (princ "      " file_id)
    
48. (princ "Area= " file_id) (princ "      " file_id)
    
49. 
    
50. (while (/= Area_cad_id nil)
    
51.    (setq n (+ n 1))
    
52.    (princ "\n" file_id)
    
53.   (princ n file_id)  (princ ",  " file_id)
    
54.   (princ aa2 file_id)
    
55.   (prompt "\n 请选取要输出的面域： ")
    
56.   (setq ent_list (ssget :s))
    
57.   ;(setq ent_list_len (sslength ent_list))
    
58.   (setq ent_data (entget (ssname ent_list 0)))
    
59.   (setq Area_cad_id (cdr (assoc -1 ent_data)))
    
60.   ;(setq Area_cad_id (car ent_data))
    
61.   (setq A_id (vlax-ename->vla-object Area_cad_id))
    
62.   (setq aa1 (vla-get-Area A_id))
    
63.   (setq aa2 (rtos aa1 2))
    
64.   (setq pt (getpoint "\n 请输入文本的起始点："))
    
65.   (setq pt1 (getpoint "\n 请输入标注点："))
    
66.   (command "line" pt pt1 "")
    
67.   (command "text" "bc" pt 3.0 0 aa2)
    
68.    )
    
69. 
    
70.   ;(close file_id)
    
71.   (setvar "blipmode" orig_blip)
    
72.   (setvar "cmdecho" orig_cmd)
    
73.   (prin1)
    
74. ); end of Lt-on
    
75. 
    
76.         (setq msg_ "\n .........Command: ga .........\n")
    
77.         (prompt msg_)

<br /> ; ga.Lsp<br /> ; 面积输出<br /> ; Auguest 29th 2001 <br /> <br /> ; ent ent_data ent_lay_new ent_lay_name ent_list ent_list_len<br /> ; id ent_lay_old ent_data_new msg1 msg2<br /> <br /> (defun c:llsp()<br />   (load "ga")<br /> )<br /> <br /> (defun c:ga(/ orig_blip orig_cmd put_out file_name file_id<br />               A1 p2 p1x p1y p2x p2 ent_data_new msg1 msg2)<br />   (vl-load-com)<br />   (setq acadObject (vlax-get-acad-object))<br />   (setq acadDocument (vla-get-Activedocument acadObject))<br />   (setq mSpace (vla-get-ModelSpace acadDocument))<br />   <br />   (setq orig_blip (getvar "blipmode"))<br />   (setq orig_cmd (getvar "cmdecho"))<br />   (setvar "blipmode" 0 )<br />   (setvar "cmdecho" 1 )<br />   (setvar "osmode" 32)<br />   <br />   (setq put_out "Area-1")<br />   (setq file_name (getfiled "请指定要输出文件的名称" put_out "txt" 1))<br />   (setq file_id (open file_name "w"))<br /> <br />   (prompt "\n 请选取要输出的面域： ")<br />   (setq ent_list (ssget :s))<br />   ;(setq ent_list_len (sslength ent_list))<br />   (setq ent_data (entget (ssname ent_list 0)))<br />   (setq Area_cad_id (cdr (assoc -1 ent_data)))<br /> ;(setq Area_cad_id (car ent_data))<br /> ;(setq Area_cad_id (car (ssget "\n 请选取要输出的面域")))<br />   (setq A_id (vlax-ename->vla-object Area_cad_id))<br />   (setq aa1 (vla-get-Area A_id))<br />   (setq aa2 (rtos aa1 2))<br />   (setq pt (getpoint "\n 请输入文本的起始点："))<br />   (setq pt1 (getpoint "\n 请输入标注点："))<br />   (command "line" pt pt1 "")<br />   (command "text" "bc" pt 3.0 0 aa2)<br />   (setq n 0)<br />   <br /> (princ "序号 " file_id) (princ "      " file_id)<br /> (princ "Area= " file_id) (princ "      " file_id)<br /> <br /> (while (/= Area_cad_id nil)<br />    (setq n (+ n 1))<br />    (princ "\n" file_id)<br />   (princ n file_id)  (princ ",  " file_id)<br />   (princ aa2 file_id)<br />   (prompt "\n 请选取要输出的面域： ")<br />   (setq ent_list (ssget :s))<br />   ;(setq ent_list_len (sslength ent_list))<br />   (setq ent_data (entget (ssname ent_list 0)))<br />   (setq Area_cad_id (cdr (assoc -1 ent_data)))<br />   ;(setq Area_cad_id (car ent_data))<br />   (setq A_id (vlax-ename->vla-object Area_cad_id))<br />   (setq aa1 (vla-get-Area A_id))<br />   (setq aa2 (rtos aa1 2))<br />   (setq pt (getpoint "\n 请输入文本的起始点："))<br />   (setq pt1 (getpoint "\n 请输入标注点："))<br />   (command "line" pt pt1 "")<br />   (command "text" "bc" pt 3.0 0 aa2)<br />    )<br /> <br />   ;(close file_id)<br />   (setvar "blipmode" orig_blip)<br />   (setvar "cmdecho" orig_cmd)<br />   (prin1)<br /> ); end of Lt-on<br /> <br />         (setq msg_ "\n .........Command: ga .........\n")<br />         (prompt msg_)

星期八

这个什么用阿，那位指点一下阿。
谢谢，^_^

自由的鱼

看不懂LISP，楼主能写个详细点的说明吗？

lhj743

好用！
物体要一个一个选择，面积一次出现！

gdqbx

好用，但数值怎么输不出到文本文件呢？我用的是2004。

shisj

好像是已经存在的面域可以计算，不能自动新建面域

gdqbx

建议楼主修改，能自动新建面域，可参考这个程序。

li_seagull

怎么下载不了呀

copyyear

凑合用用，谢谢搂主

hisen

我更喜欢gdqbx 的程序，简单实用！！

xxxyzxx

恩，很高兴楼主提供源文件供大家研究，虽然目的相同但每个人编的内容都有区别，研究一下旧案有提高，现在去试试喽，感谢楼主！

cuiwenjun2008

7楼楼主的面积计算很好，但我更想要一个面积统计后能询问名称（比如住宅用地），再输出成文本文件的lisp，是不是1楼楼主的就是这个意思呀，我是不懂源程序的，希望楼主上传个lisp程序，谢谢了！

zk_hisen

谢谢搂主，收下研究学习学习 。

cuiwenjun2008

终于弄明白了楼主的意思了，使用了以后觉得很好用，谢谢楼主，但是为什么不能输出到文本文件呢？请楼主解释一下

rains

好！谢谢了！