实用！输出已编号的圆心坐标到EXCELL（转载源码BY lyt0623 ）

yfanzi

已有大量圆，已经编号序号，应用此程序，可以按照图上编号在EXCELL中生成一一对应的坐标表，方便。先要在E盘建个名为”123“的文件夹。然后确定CAD上的圆有编号。转载的LYT06的作品！源码在下面。

yfanzi

(defun c:yxsc()
;;; 在图中向文件E:\\123\\2.xls输出选中字体角点坐标程序
  (VL-LOAD-COM)
  (setq AcadObject(vlax-get-acad-object)
        AcadDocument(vla-get-ActiveDocument AcadObject)
        mSpace(vla-get-ModelSpace AcadDocument)
  )
  (setq fp1(open "E:\\123\\2.xls" "w"))
  (setq p1(getpoint "\n请输入第一点:"))
  (setq p2(getpoint "\n请输入第二点:"))
  (setq ss(ssget "W" P1 p2))
  (SETQ t1 "text=")
  (setq a1 0)
  (setq tt1(cdr(assoc 1 (entget(ssname ss a1)))))
  (setq d1(cdr(assoc 10 (entget(ssname ss a1)))))
  (princ "\t" fp1)  (princ tt1 fp1)
  (princ "\t" fp1)  (princ "x=" fp1)  
    (princ "\t" fp1)  (princ (cadr d1) fp1)
   (princ "\t" fp1)  (princ "y=" fp1)
  (princ "\t" fp1)  (princ (car d1) fp1)
  (while  (ssname ss (+ a1 1))
    (setq a1 (+ a1 1))
    (setq tt1 (cdr (assoc 1 (entget(ssname ss a1)))))
     (setq d1 (cdr (assoc 10 (entget(ssname ss a1)))))
    (print t1 fp1)
      (princ "\t" fp1)  (princ tt1 fp1)
  (princ "\t" fp1)  (princ "x=" fp1)
       (princ "\t" fp1)  (princ (cadr d1) fp1)
   (princ "\t" fp1)  (princ "y=" fp1)
  (princ "\t" fp1)  (princ (car d1) fp1)
    )
  (close fp1)
  
)
也是刚使用，觉着好，就翻出来贴上了。大家一起讨论一下有无问题？

sen.sam

无聊，小改了一下，可以自选输出目录和文件名，改用鼠标框选，增加出错时关闭文档，免得被cad锁定文档

2. (defun c:xxx()
   
3.    (setq olderror *error*)
   
4.      (setq *error* zxx_err)
   
5.   (if (not currdir)
   
6.          (setq currdir "d:\")
   
7.      )
   
8. 
   
9.     (setq of(getfiled "输出文件名" currdir "xls" 1))
   
10.   
    
11.   (setq currdir (strcat (vl-filename-directory of) "\"))  ;记忆本次的路径
    
12.   (setq ss(ssget '((-4 . "<or")(0 . "text")(0 . "mtext")(-4 . "or>"))) )
    
13.   (SETQ t1 "text=")
    
14.   (setq a1 0)
    
15.   (setq tt1(cdr(assoc 1 (entget(ssname ss a1)))))
    
16.   (setq d1(cdr(assoc 10 (entget(ssname ss a1)))))
    
17.   (setq fp1(open of "w"))
    
18.   (princ "\t" fp1)  (princ tt1 fp1)
    
19.   (princ "\t" fp1)  (princ "x=" fp1)  
    
20.     (princ "\t" fp1)  (princ (cadr d1) fp1)
    
21.    (princ "\t" fp1)  (princ "y=" fp1)
    
22.   (princ "\t" fp1)  (princ (car d1) fp1)
    
23.   (while  (ssname ss (+ a1 1))
    
24.     (setq a1 (+ a1 1))
    
25.     (setq tt1 (cdr (assoc 1 (entget(ssname ss a1)))))
    
26.      (setq d1 (cdr (assoc 10 (entget(ssname ss a1)))))
    
27.     (print t1 fp1)
    
28.       (princ "\t" fp1)  (princ tt1 fp1)
    
29.   (princ "\t" fp1)  (princ "x=" fp1)
    
30.        (princ "\t" fp1)  (princ (cadr d1) fp1)
    
31.    (princ "\t" fp1)  (princ "y=" fp1)
    
32.   (princ "\t" fp1)  (princ (car d1) fp1)
    
33.     )
    
34.   (close fp1)
    
35.   (princ)
    
36.   
    
37. )
    
38. 
    
39. 
    
40. (defun zxx_err(msg)
    
41. 
    
42. (setq *error* olderror)
    
43. 
    
44. ( if fp1
    
45.      (close fp1)
    
46. )
    
47. 
    
48. (princ)
    
49. )

(defun c:xxx()<br />    (setq olderror *error*)<br />      (setq *error* zxx_err)<br />   (if (not currdir)<br />          (setq currdir "d:\")<br />      )<br /> <br />     (setq of(getfiled "输出文件名" currdir "xls" 1))<br />   <br />   (setq currdir (strcat (vl-filename-directory of) "\"))  ;记忆本次的路径<br />   (setq ss(ssget '((-4 . "<or")(0 . "text")(0 . "mtext")(-4 . "or>"))) )<br />   (SETQ t1 "text=")<br />   (setq a1 0)<br />   (setq tt1(cdr(assoc 1 (entget(ssname ss a1)))))<br />   (setq d1(cdr(assoc 10 (entget(ssname ss a1)))))<br />   (setq fp1(open of "w"))<br />   (princ "\t" fp1)  (princ tt1 fp1)<br />   (princ "\t" fp1)  (princ "x=" fp1)  <br />     (princ "\t" fp1)  (princ (cadr d1) fp1)<br />    (princ "\t" fp1)  (princ "y=" fp1)<br />   (princ "\t" fp1)  (princ (car d1) fp1)<br />   (while  (ssname ss (+ a1 1))<br />     (setq a1 (+ a1 1))<br />     (setq tt1 (cdr (assoc 1 (entget(ssname ss a1)))))<br />      (setq d1 (cdr (assoc 10 (entget(ssname ss a1)))))<br />     (print t1 fp1)<br />       (princ "\t" fp1)  (princ tt1 fp1)<br />   (princ "\t" fp1)  (princ "x=" fp1)<br />        (princ "\t" fp1)  (princ (cadr d1) fp1)<br />    (princ "\t" fp1)  (princ "y=" fp1)<br />   (princ "\t" fp1)  (princ (car d1) fp1)<br />     )<br />   (close fp1)<br />   (princ)<br />   <br /> )<br /> <br /> <br /> (defun zxx_err(msg)<br /> <br /> (setq *error* olderror)<br /> <br /> ( if fp1<br />      (close fp1)<br /> )<br /> <br /> (princ)<br /> )

yfanzi

坐标要小数点后保留4位，在哪里改改？

sen.sam

改了一下，保留小数点后四位

2. (defun c:xxx()
   
3.    (setq olderror *error*)
   
4.      (setq *error* zxx_err)
   
5.   (if (not currdir)
   
6.          (setq currdir "d:\")
   
7.      )
   
8.     (setq of(getfiled "输出文件名" currdir "xls" 1))
   
9.   
   
10.   (setq currdir (strcat (vl-filename-directory of) "\"))  ;记忆本次的路径
    
11.   (setq ss(ssget '((-4 . "<or")(0 . "text")(0 . "mtext")(-4 . "or>"))) )
    
12.   (SETQ t1 "text=")
    
13.   (setq a1 0)
    
14.   (setq nnn(sslength ss))  
    
15.   (repeat nnn
    
16.     (setq tt1 (cdr (assoc 1 (entget(ssname ss a1)))))
    
17.     (setq d1 (cdr (assoc 10 (entget(ssname ss a1)))))
    
18.     (print t1 fp1)
    
19.     (princ "\t" fp1)  (princ tt1 fp1)
    
20.     (princ "\t" fp1)  (princ "x=" fp1)
    
21.     (princ "\t" fp1)  (princ (rtos(cadr d1)2 4) fp1)
    
22.     (princ "\t" fp1)  (princ "y=" fp1)
    
23.     (princ "\t" fp1)  (princ (rtos(car d1)2 4) fp1)
    
24.     (setq a1(+ a1 1))
    
25.    )
    
26.    (close fp1)
    
27.    
    
28.   (princ)
    
29.   
    
30. )
    
31. 
    
32. (defun zxx_err(msg)
    
33. 
    
34. (setq *error* olderror)
    
35. ( if fp1
    
36.      (close fp1)
    
37. )
    
38. (princ)
    
39. )

(defun c:xxx()<br />    (setq olderror *error*)<br />      (setq *error* zxx_err)<br />   (if (not currdir)<br />          (setq currdir "d:\")<br />      )<br />     (setq of(getfiled "输出文件名" currdir "xls" 1))<br />   <br />   (setq currdir (strcat (vl-filename-directory of) "\"))  ;记忆本次的路径<br />   (setq ss(ssget '((-4 . "<or")(0 . "text")(0 . "mtext")(-4 . "or>"))) )<br />   (SETQ t1 "text=")<br />   (setq a1 0)<br />   (setq nnn(sslength ss))  <br />   (repeat nnn <br />     (setq tt1 (cdr (assoc 1 (entget(ssname ss a1)))))<br />     (setq d1 (cdr (assoc 10 (entget(ssname ss a1)))))<br />     (print t1 fp1)<br />     (princ "\t" fp1)  (princ tt1 fp1)<br />     (princ "\t" fp1)  (princ "x=" fp1)<br />     (princ "\t" fp1)  (princ (rtos(cadr d1)2 4) fp1)<br />     (princ "\t" fp1)  (princ "y=" fp1)<br />     (princ "\t" fp1)  (princ (rtos(car d1)2 4) fp1)<br />     (setq a1(+ a1 1))<br />    )<br />    (close fp1)<br />    <br />   (princ)<br />   <br /> )<br /> <br /> (defun zxx_err(msg)<br /> <br /> (setq *error* olderror)<br /> ( if fp1<br />      (close fp1)<br /> )<br /> (princ)<br /> )

yfanzi

没法生成EXCELL表格了，是不是少了句(setq fp1(open of "w"))啊！？

sen.sam

yfanzi 发表于 2011-10-20 15:04
没法生成EXCELL表格了，是不是少了句(setq fp1(open of "w"))啊！？

呵呵，改的时候不小心错删了，加上就行了！

yfanzi

呵呵，感谢，这下好用多了！

jxphklibin

就这些？？？？？