求助批量提取CAD中的文字（TEXT)程序

yx1985321

哪位大神批量提取CAD中的文字（TEXT)的程序啊。上传一个吧

香田里浪人

论坛里已有。请楼主仔细找。

yx1985321

老大，找了好久没有找到啊，能传一个吗？谢谢

byghbcx

提取文字后做什么处理？选择没问题。

ZZXXQQ

2. (defun c:tt ()
   
3. (setq fnm (if (= (type fnm) 'STR) fnm ""))
   
4. (if (and (setq fnm (getfiled "选择输出文件" fnm "txt" 1))
   
5.            (setq ss (ssget '((0 . "TEXT"))))) (progn
   
6.   (setq fp (open fnm "w"))
   
7.   (repeat (setq n (sslength ss))
   
8.    (setq ent (entget(ssname ss (setq n (1- n)))))
   
9.    (print  (cdr(assoc 1 ent)) fp)
   
10.   )
    
11.   (close fp)
    
12. ))
    
13. (princ)
    
14. )

(defun c:tt ()<br /> (setq fnm (if (= (type fnm) 'STR) fnm ""))<br /> (if (and (setq fnm (getfiled "选择输出文件" fnm "txt" 1))<br />            (setq ss (ssget '((0 . "TEXT"))))) (progn<br />   (setq fp (open fnm "w"))<br />   (repeat (setq n (sslength ss))<br />    (setq ent (entget(ssname ss (setq n (1- n)))))<br />    (print  (cdr(assoc 1 ent)) fp)<br />   )<br />   (close fp)<br /> ))<br /> (princ)<br /> )

004

1. ;;;wkq004  QQ:278416560 2009.02.24 13572449833
   
2. (vl-load-com)
   
3. (defun c:ZB (/             CENTER  COLOR   DIRECTORY             E             E2
   
4.              E2L     EEL     EL             FILENAME             FL             LAYERNAME
   
5.              MYACAD  N             SS             SS2     SS3     SSE     START
   
6.              STRING  XH1     XH2
   
7.             )
   
8.   (setvar "cmdecho" 0)
   
9.   (setq osmode (getvar "osmode"))
   
10.   (setvar "osmode" 0)
    
11.   (command "layer" "M" "导出层" "C" 8 "" "")
    
12.   (setq xh1 1)
    
13.   (setq xh2 1)
    
14.   (while (= 1 xh1)
    
15.     (while (= 1 xh2)
    
16.       (princ "\n[结束选择(空格/回车/右键)]请点选要导出的圆:")
    
17.       (if
    
18.         (setq ss3 (ssget ":S" '((0 . "TEXT"))))
    
19.          (progn
    
20.            (setq sse (ssname ss3 0))
    
21.            (setq eel (entget sse))
    
22.            (setq layername (cdr (assoc 8 eel)))
    
23.            (if (setq color (cdr (assoc 62 eel)))
    
24.              (setq ss2
    
25.                     (ssget
    
26.                       "X"
    
27.                       (list (cons 0 "TEXT")
    
28.                             (cons 8 layername)
    
29.                             (cons 62 color)
    
30.                       )
    
31.                     )
    
32.              )
    
33.              (setq
    
34.                ss2
    
35.                 (ssget "X" (list (cons 0 "TEXT") (cons 8 layername)))
    
36.              )
    
37.            )
    
38.            (setq n 0)
    
39.            (command ".undo" "begin")
    
40.            (repeat (sslength ss2)
    
41.              (setq e2 (ssname ss2 n))
    
42.              (setq e2l (entget e2))
    
43.              (setq e2l (subst (cons 8 "导出层") (assoc 8 e2l) e2l))
    
44.              (setq e2l (subst (cons 62 256) (assoc 62 e2l) e2l))
    
45.              (entmod e2l)
    
46.              (setq n (1+ n))
    
47.            )
    
48.            (command ".undo" "end")
    
49.          )
    
50.          (progn
    
51.            (setq xh2 0)
    
52.          )
    
53.       )
    
54.     )
    
55.     (initget 1 "D X E")
    
56.     (setq start (getreal "\n[退出(E)继续选择(X)]导出请输入(D):"))
    
57.     (if        (= "D" start)
    
58.       (progn
    
59.         (if
    
60.           (setq ss (ssget "X" '((8 . "导出层") (0 . "TEXT"))))
    
61.            (progn
    
62.              (setq myacad (vlax-get-acad-object))
    
63.              (setq filename (vl-filename-base (vla-get-caption myacad)))
    
64.              (while (vl-file-systime (strcat "c:/" filename ".txt"))
    
65.                (setq filename (strcat filename "-1"))
    
66.              )
    
67.              (setq directory (strcat "c:/" filename ".txt"))
    
68.              (setq fl (open directory "w"))
    
69.              (setq n 0)
    
70.              (repeat (sslength ss)
    
71.                (setq e (ssname ss n))
    
72.                (setq el (entget e))
    
73.                (setq n (1+ n))
    
74.                (setq center (cdr (assoc 10 el)))
    
75.                (setq text (cdr (assoc 1 el)))
    
76.                (setq
    
77.                  string        (strcat        (setq text (cdr (assoc 1 el)))
    
78.                                 ",,"
    
79.                                 (rtos (car center) 2 3)
    
80.                                 ","
    
81.                                 (rtos (cadr center) 2 3)
    
82.                                 ","
    
83.                                 (rtos (last center) 2 3)
    
84.                         )
    
85.                )
    
86.                (write-line string fl)
    
87.              )
    
88.              (close fl)
    
89.              (princ (strcat "\n坐标导出成功" directory))
    
90.              (setq xh1 0)
    
91.            )
    
92.            (progn
    
93.              (princ "\n在\"导出层\"内没有圆可供导出,程序终止!!")
    
94.              (setq xh1 0)
    
95.            )
    
96.         )
    
97.       )
    
98.       (progn
    
99.         (if (= "X" start)
    
100.           (setq xh2 1)
     
101.           (setq xh1 0)
     
102.         )
     
103.       )
     
104.     )
     
105.   )
     
106.   (setvar "cmdecho" 1)
     
107.   (setvar "osmode" osmode)
     
108.   (princ)
     
109. )
     
110. 
     
111. 
     
112. 
     
113. 
     

;;;wkq004  QQ:278416560 2009.02.24 13572449833<br /> (vl-load-com)<br /> (defun c:ZB (/             CENTER  COLOR   DIRECTORY             E             E2<br />              E2L     EEL     EL             FILENAME             FL             LAYERNAME<br />              MYACAD  N             SS             SS2     SS3     SSE     START<br />              STRING  XH1     XH2<br />             )<br />   (setvar "cmdecho" 0)<br />   (setq osmode (getvar "osmode"))<br />   (setvar "osmode" 0)<br />   (command "layer" "M" "导出层" "C" 8 "" "")<br />   (setq xh1 1)<br />   (setq xh2 1)<br />   (while (= 1 xh1)<br />     (while (= 1 xh2)<br />       (princ "\n[结束选择(空格/回车/右键)]请点选要导出的圆:")<br />       (if<br />         (setq ss3 (ssget ":S" '((0 . "TEXT"))))<br />          (progn<br />            (setq sse (ssname ss3 0))<br />            (setq eel (entget sse))<br />            (setq layername (cdr (assoc 8 eel)))<br />            (if (setq color (cdr (assoc 62 eel)))<br />              (setq ss2<br />                     (ssget<br />                       "X"<br />                       (list (cons 0 "TEXT")<br />                             (cons 8 layername)<br />                             (cons 62 color)<br />                       )<br />                     )<br />              )<br />              (setq<br />                ss2<br />                 (ssget "X" (list (cons 0 "TEXT") (cons 8 layername)))<br />              )<br />            )<br />            (setq n 0)<br />            (command ".undo" "begin")<br />            (repeat (sslength ss2)<br />              (setq e2 (ssname ss2 n))<br />              (setq e2l (entget e2))<br />              (setq e2l (subst (cons 8 "导出层") (assoc 8 e2l) e2l))<br />              (setq e2l (subst (cons 62 256) (assoc 62 e2l) e2l))<br />              (entmod e2l)<br />              (setq n (1+ n))<br />            )<br />            (command ".undo" "end")<br />          )<br />          (progn<br />            (setq xh2 0)<br />          )<br />       )<br />     )<br />     (initget 1 "D X E")<br />     (setq start (getreal "\n[退出(E)继续选择(X)]导出请输入(D):"))<br />     (if        (= "D" start)<br />       (progn<br />         (if<br />           (setq ss (ssget "X" '((8 . "导出层") (0 . "TEXT"))))<br />            (progn<br />              (setq myacad (vlax-get-acad-object))<br />              (setq filename (vl-filename-base (vla-get-caption myacad)))<br />              (while (vl-file-systime (strcat "c:/" filename ".txt"))<br />                (setq filename (strcat filename "-1"))<br />              )<br />              (setq directory (strcat "c:/" filename ".txt"))<br />              (setq fl (open directory "w"))<br />              (setq n 0)<br />              (repeat (sslength ss)<br />                (setq e (ssname ss n))<br />                (setq el (entget e))<br />                (setq n (1+ n))<br />                (setq center (cdr (assoc 10 el)))<br />                (setq text (cdr (assoc 1 el)))<br />                (setq<br />                  string        (strcat        (setq text (cdr (assoc 1 el)))<br />                                 ",,"<br />                                 (rtos (car center) 2 3)<br />                                 ","<br />                                 (rtos (cadr center) 2 3)<br />                                 ","<br />                                 (rtos (last center) 2 3)<br />                         )<br />                )<br />                (write-line string fl)<br />              )<br />              (close fl)<br />              (princ (strcat "\n坐标导出成功" directory))<br />              (setq xh1 0)<br />            )<br />            (progn<br />              (princ "\n在\"导出层\"内没有圆可供导出,程序终止!!")<br />              (setq xh1 0)<br />            )<br />         )<br />       )<br />       (progn<br />         (if (= "X" start)<br />           (setq xh2 1)<br />           (setq xh1 0)<br />         )<br />       )<br />     )<br />   )<br />   (setvar "cmdecho" 1)<br />   (setvar "osmode" osmode)<br />   (princ)<br /> )<br /> <br /> <br /> <br /> <br />

香田里浪人

;;;取得图层所有文本.
(defun c:outdoc()
(setq fnm (getfiled "保存文件名" "" "doc" 1))
　(setq fn (open fnm "w"))
　(setq s (ssget))
　(setq n (sslength s))
　(setq index ( - n 1))
　(repeat n
　　(setq ents (entget (ssname s index)))
　　(setq index ( - index 1))
　　(setq ent (assoc 0 ents))
　　(if ( = "TEXT" (cdr ent))
　　　　(progn
　　　　　　(setq txt (cdr (assoc 1 ents)))
　　　　　　(write-line txt fn)
　　　　)
　　)
　)
(close fn)
)

yx1985321

谢谢，挺好用的

yunkongming

香田里浪人 发表于 2014-5-25 06:24
;;;取得图层所有文本.
(defun c:outdoc()
(setq fnm (getfiled "保存文件名" "" "doc" 1))

老大：
取得图层所有文本. 中不能指定图层，数据乱，
求怎样解决？

kozmosovia

可以直接使用DATAEXTRACTION命令