实用！输出已编号的圆心坐标到EXCELL（转载源码BY lyt0623 ）
已有大量圆，已经编号序号，应用此程序，可以按照图上编号在EXCELL中生成一一对应的坐标表，方便。先要在E盘建个名为”123“的文件夹。然后确定CAD上的圆有编号。转载的LYT06的作品！源码在下面。 (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)
)
也是刚使用，觉着好，就翻出来贴上了。大家一起讨论一下有无问题？ 无聊，小改了一下，可以自选输出目录和文件名，改用鼠标框选，增加出错时关闭文档，免得被cad锁定文档(defun c:xxx()
(setq olderror *error*)
(setq *error* zxx_err)
(if (not currdir)
(setq currdir "d:\\")
)
(setq of(getfiled "输出文件名" currdir "xls" 1))
(setq currdir (strcat (vl-filename-directory of) "\\"));记忆本次的路径
(setq ss(ssget '((-4 . "<or")(0 . "text")(0 . "mtext")(-4 . "or>"))) )
(SETQ t1 "text=")
(setq a1 0)
(setq tt1(cdr(assoc 1 (entget(ssname ss a1)))))
(setq d1(cdr(assoc 10 (entget(ssname ss a1)))))
(setq fp1(open of "w"))
(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)
(princ)
)
(defun zxx_err(msg)
(setq *error* olderror)
( if fp1
(close fp1)
)
(princ)
) 坐标要小数点后保留4位，在哪里改改？ 改了一下，保留小数点后四位(defun c:xxx()
(setq olderror *error*)
(setq *error* zxx_err)
(if (not currdir)
(setq currdir "d:\\")
)
(setq of(getfiled "输出文件名" currdir "xls" 1))
(setq currdir (strcat (vl-filename-directory of) "\\"));记忆本次的路径
(setq ss(ssget '((-4 . "<or")(0 . "text")(0 . "mtext")(-4 . "or>"))) )
(SETQ t1 "text=")
(setq a1 0)
(setq nnn(sslength ss))
(repeat nnn
(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 (rtos(cadr d1)2 4) fp1)
(princ "\t" fp1)(princ "y=" fp1)
(princ "\t" fp1)(princ (rtos(car d1)2 4) fp1)
(setq a1(+ a1 1))
)
(close fp1)
(princ)
)
(defun zxx_err(msg)
(setq *error* olderror)
( if fp1
(close fp1)
)
(princ)
) 没法生成EXCELL表格了，是不是少了句(setq fp1(open of "w"))啊！？ yfanzi 发表于 2011-10-20 15:04 static/image/common/back.gif
没法生成EXCELL表格了，是不是少了句(setq fp1(open of "w"))啊！？
呵呵，改的时候不小心错删了，加上就行了！ 呵呵，感谢，这下好用多了！ 就这些？？？？？
页:
[1]
2