保存指定文字对象的文字内容及文字所在位置块的图层名称和块名称到文本

1681008

保存指定文字对象的文字内容及文字所在位置块的图层名称和块名称到文本


保存的txt数据格式：
文字内容,文字处块所在图层名称,文字处块名称
1,A,ZH1
18,A,ZH2
168,A,ZH3
8-1,D-2,ZH3
8-18,D-2,ZH1
8-168,D-2,ZH2
DSY1,8,ZH1
DSY18,8,ZH2
DSY168,8,ZH3

有劳论坛大神百忙中抽空弄个lsp用用！谢谢！谢谢！！

ssyfeng

修改了保存与当前dwg同名同目录的txt文件：

ssyfeng

试试这个行不行：

2. (defun c:tt (/ *error* blc-en blc-name blc-name0 cr-pt dis0 dis1 en en-pt lay lay0 lst lst0 pt1 pt2 ss1 ss1-n ss2 ss2-n str txt-file)
   
3.   (defun *error* ( msg )
   
4.     (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
   
5.       (progn (princ (strcat "\n错误：" msg)) (close txt-file))
   
6.     )
   
7.     (princ)
   
8.   )
   
9.   (setq pt1 (getpoint "\n选择对象范围：")
   
10.     pt2 (getcorner pt1 "\n选择对象范围：")
    
11.     ss1 (ssget "_c" pt1 pt2 '((0 . "text") (8 . "编号")))
    
12.     ss2 (ssget "_c" pt1 pt2 '((0 . "INSERT")))
    
13.     ss1-n (sslength ss1)
    
14.     ss2-n (sslength ss2)
    
15.     txt-file (open "c:\\str-lay-name.txt" "w")
    
16.   )
    
17.   (repeat ss1-n
    
18.     (setq en (ssname ss1 (setq ss1-n (1- ss1-n)))
    
19.       str (cdr (assoc 1 (entget en)))
    
20.       en-pt (cdr (assoc 10 (entget en)))
    
21.       dis0 99999999
    
22.     )
    
23.     (repeat ss2-n
    
24.       (setq blc-en (ssname ss2 (setq ss2-n (1- ss2-n)))
    
25.         cr-pt (cdr (assoc 10 (entget blc-en)))
    
26.         blc-name (cdr (assoc 2 (entget blc-en)))
    
27.         lay (cdr (assoc 8 (entget blc-en)))
    
28.         dis1 (distance en-pt cr-pt)
    
29.       )
    
30.       (if (< dis1 dis0)
    
31.         (progn (setq dis0 dis1
    
32.                  blc-name0 blc-name
    
33.                  lay0 lay
    
34.                )
    
35.         )
    
36.       )
    
37.     )
    
38.     (setq lst0 (append lst0 (list (list str lay0 blc-name0)))
    
39.       ss2-n (sslength ss2)
    
40.     )
    
41.   )
    
42.   (setq lst (mapcar '(lambda (x) (strcat (car x) "," (cadr x) "," (caddr x))) lst0))
    
43.   (mapcar '(lambda (x) (write-line x txt-file)) lst)
    
44.   (close txt-file)
    
45.   (princ)
    
46. )

(defun c:tt (/ *error* blc-en blc-name blc-name0 cr-pt dis0 dis1 en en-pt lay lay0 lst lst0 pt1 pt2 ss1 ss1-n ss2 ss2-n str txt-file)<br />   (defun *error* ( msg )<br />     (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))<br />       (progn (princ (strcat "\n错误：" msg)) (close txt-file))<br />     )<br />     (princ)<br />   )<br />   (setq pt1 (getpoint "\n选择对象范围：")<br />     pt2 (getcorner pt1 "\n选择对象范围：")<br />     ss1 (ssget "_c" pt1 pt2 '((0 . "text") (8 . "编号")))<br />     ss2 (ssget "_c" pt1 pt2 '((0 . "INSERT")))<br />     ss1-n (sslength ss1)<br />     ss2-n (sslength ss2)<br />     txt-file (open "c:\\str-lay-name.txt" "w")<br />   )<br />   (repeat ss1-n <br />     (setq en (ssname ss1 (setq ss1-n (1- ss1-n)))<br />       str (cdr (assoc 1 (entget en)))<br />       en-pt (cdr (assoc 10 (entget en)))<br />       dis0 99999999<br />     )<br />     (repeat ss2-n <br />       (setq blc-en (ssname ss2 (setq ss2-n (1- ss2-n)))<br />         cr-pt (cdr (assoc 10 (entget blc-en)))<br />         blc-name (cdr (assoc 2 (entget blc-en)))<br />         lay (cdr (assoc 8 (entget blc-en)))<br />         dis1 (distance en-pt cr-pt)<br />       )<br />       (if (< dis1 dis0) <br />         (progn (setq dis0 dis1 <br />                  blc-name0 blc-name<br />                  lay0 lay<br />                )<br />         )<br />       )<br />     )<br />     (setq lst0 (append lst0 (list (list str lay0 blc-name0)))<br />       ss2-n (sslength ss2)<br />     )<br />   )<br />   (setq lst (mapcar '(lambda (x) (strcat (car x) "," (cadr x) "," (caddr x))) lst0))<br />   (mapcar '(lambda (x) (write-line x txt-file)) lst)<br />   (close txt-file)<br />   (princ)<br /> )

1681008

ssyfeng 发表于 2018-11-5 15:12
试试这个行不行：

有劳大神看看，这是什么情况？谢谢！谢谢！！

ssyfeng

你重新下载最新的试试

1681008

ssyfeng 发表于 2018-11-5 17:05
你重新下载最新的试试

是用的 2018-11-5 16:28 编辑的代码，不知道是不是我CAD版本的问题，我用的是cad2016
还有想请教下，当块数量多一点的时候，比如800多个就有会停止响应一回儿，如图：

最后运行的结果还是没像您演示动画里生成了txt文件，只在命令历史记录里有显示：

有劳大神给看看是什么情况，再次表示衷心的感谢，谢谢！！

ssyfeng

你用的应该还是旧的，我打包上传吧，你重新打开CAD，再加载试试

1681008

ssyfeng 发表于 2018-11-5 17:28
你用的应该还是旧的，我打包上传吧，你重新打开CAD，再加载试试

我对比了下您上传的lisp和2楼的代码是一致的，
运行结果也如上所叙，有劳您再给看看，谢谢！

ssyfeng

下班了，迟一点再看看

ssyfeng

上传你测试的文件看看