快速遍历统计目录下面所有dwg的图层名字

dcl1214

客户让我写一个统计图层名字的程序，写完了，感觉没啥用，分享出来，同时也是给自己做一个笔记

1. (DEFUN C:TCTJ (/
   
2.          $lie-chu-mu-lu-xia-suo-you-wen-jian$
   
3.          delsame          dwgs
   
4.          file          get-text-style-all-dbx
   
5.          merge-str-by-bar        setcliptext
   
6.          tcs          zx-getfolder
   
7.         )
   
8.   (defun get-text-style-all-dbx  (dwg    /     *error*
   
9.          _getattributes     app      dbx
   
10.          dir    doc     dwl      err
    
11.          rtn    vrs     dwg-n    open-zt
    
12.          MACRO    pt
    
13.         )
    
14.           ;使用dbx读取外部dwg里面的所有属性块的属性
    
15.     (defun *error* (msg)
    
16.       (if (and (= 'vla-object (type dbx))
    
17.          (not (vlax-object-released-p dbx))
    
18.     )
    
19.   (vlax-release-object dbx)
    
20.       )
    
21.       (vl-catch-all-apply (function (lambda () (c:var nil nil))))
    
22.           ;强制将变量还原
    
23.       (princ)
    
24.     )
    
25.     (defun get-text-style (doc / n ns obj)
    
26.       (SETQ MACRO "█")
    
27.       (sETVAR "modemacro" MACRO)
    
28.       (setq ns nil)
    
29.       (vlax-for  obj (vla-get-LAYERs doc)
    
30.   (setq n (vla-get-name obj))
    
31.   (setq ns (cons n ns))
    
32.       )
    
33.       ns
    
34.     )
    
35.     (if  (and dwg (findfile dwg))
    
36.       (cond
    
37.   ((progn
    
38.      (setq dbx
    
39.       (vl-catch-all-apply
    
40.         'vla-getinterfaceobject
    
41.         (list (setq app (vlax-get-acad-object))
    
42.         (if (< (setq vrs (atoi (getvar 'acadver))) 16)
    
43.           "objectdbx.axdbdocument"
    
44.           (strcat "objectdbx.axdbdocument." (itoa vrs))
    
45.         )
    
46.         )
    
47.       )
    
48.      )
    
49.      (or (null dbx) (vl-catch-all-error-p dbx))
    
50.    )
    
51.    (prompt "调用dbx组件失败，请重装完整版cad")
    
52.   )
    
53.   (t
    
54.    (vlax-for doc (vla-get-documents app)
    
55.      (setq
    
56.        dwl
    
57.         (cons (cons (strcase (vla-get-fullname doc)) doc) dwl)
    
58.      )
    
59.    )
    
60.    (and (vl-file-copy
    
61.     dwg
    
62.     (setq dwg-n (vl-filename-mktemp "1.dwg"))
    
63.         )        ;复制一个dwg再打开
    
64.         (setq dwg dwg-n)
    
65.         (setq
    
66.     open-zt  (vl-catch-all-error-p
    
67.         (vl-catch-all-apply 'vla-open (list dbx dwg))
    
68.       )
    
69.         )
    
70.         (not (vl-catch-all-error-p open-zt))
    
71.    )
    
72.    (if
    
73.      (and  (not (vl-catch-all-error-p open-zt))
    
74.     (setq doc dbx)
    
75.      )
    
76.       (progn
    
77.         (setq rtn
    
78.          (if (vl-catch-all-error-p
    
79.          (setq err
    
80.           (vl-catch-all-apply
    
81.             (FUNCTION (LAMBDA () (get-text-style doc)))
    
82.           )
    
83.          )
    
84.        )
    
85.            (progn (print)
    
86.             (princ dwg)
    
87.             (princ "   ")
    
88.             (princ (vl-catch-all-error-message err))
    
89.            )
    
90.            err
    
91.          )
    
92.         )
    
93.       )
    
94.       (princ (strcat "dwg打开失败了: "
    
95.          (vl-filename-base dwg)
    
96.          ".dwg"
    
97.        )
    
98.       )
    
99.    )
    
100.    (if (= 'vla-object (type dbx))
     
101.      (vlax-release-object dbx)
     
102.    )
     
103.    (vl-catch-all-apply
     
104.      (FUNCTION (LAMBDA () (vl-file-delete dwg-n)))
     
105.           ;删除复制的文件
     
106.    )
     
107.    rtn
     
108.   )
     
109.       )
     
110.     )
     
111.     (sETVAR "modemacro" "中线CAD")
     
112.     rtn
     
113.   )
     
114.   (defun $lie-chu-mu-lu-xia-suo-you-wen-jian$
     
115.    (lst / a f fs fs-all kzm n ns ns-1 wj wjs)
     
116.           ;列出目录下所有文件，含子级目录，所有目录下的文件
     
117.           ;示例$lie-chu-mu-lu-xia-suo-you-wen-jian$(list(cons "目录" "C:\\uploads")(cons "扩展名" "*.dwg")))
     
118.     (or  (and lst
     
119.        (= (type lst) 'list)
     
120.        (setq kzm (cdr (assoc "扩展名" lst)))
     
121.        (> (strlen kzm) 0)
     
122.        (wcmatch kzm "[,`*.*,]")
     
123.   )
     
124.   (setq kzm "*.*")
     
125.     )
     
126.     (or  (and lst
     
127.        (= (type lst) 'list)
     
128.        (setq f (cdr (assoc "目录" lst)))
     
129.   )
     
130.   (and lst (= (type lst) 'str) (setq f lst))
     
131.     )
     
132.     (and
     
133.       f
     
134.       kzm
     
135.       (findfile f)
     
136.       (progn
     
137.   (while (and f (wcmatch f "*`\\*"))
     
138.     (setq f (vl-string-subst "/" "\\" f))
     
139.   )
     
140.   (setq fs-all nil)
     
141.   (setq fs-all (cons f fs-all))
     
142.   (setq fs (vl-directory-files f "*.*" -1))
     
143.   (setq fs (vl-remove ".." fs))
     
144.   (setq fs (vl-remove "." fs))
     
145.   (setq fs (mapcar (function (lambda (a) (strcat f "/" a))) fs))
     
146.   (setq fs-all (APPEND fs-all fs))
     
147.   (while (AND fs (setq f (last fs)) (< (length fs-all) 10000))
     
148.     (setq ns nil)
     
149.     (setq ns (vl-directory-files f "*.*" -1))
     
150.     (setq ns (vl-remove ".." ns))
     
151.     (setq ns (vl-remove "." ns))
     
152.     (while (setq a (car ns))
     
153.       (setq n (strcat f "/" a))
     
154.       (setq fs (cons n fs))
     
155.       (setq fs-all (cons n fs-all))
     
156.       (setq ns (cdr ns))
     
157.     )
     
158.     (setq fs (reverse (cdr (reverse fs))))
     
159.   )
     
160.   (and fs-all
     
161.        (progn
     
162.          (setq wjs nil)
     
163.          (while (setq a (car fs-all))
     
164.      (setq wj nil)
     
165.      (setq wj (vl-directory-files a kzm 1))
     
166.      (setq wj (vl-remove ".." wj))
     
167.      (setq wj (vl-remove "." wj))
     
168.      (setq
     
169.        wj
     
170.         (mapcar (function (lambda (b) (strcat a "/" b))) wj)
     
171.      )
     
172.      (setq wjs (cons wj wjs))
     
173.      (setq fs-all (cdr fs-all))
     
174.          )
     
175.          (setq wjs (vl-remove nil wjs))
     
176.        )
     
177.   )
     
178.       )
     
179.     )
     
180.     wjs
     
181.   )
     
182.   (defun setClipText (str / html result)
     
183.           ;往剪切板上丢数据
     
184.     (if  (and str (= 'STR (type str)))
     
185.       (progn
     
186.   (setq html   (vlax-create-object "htmlfile")
     
187.         result (vlax-invoke
     
188.            (vlax-get (vlax-get html 'ParentWindow)
     
189.          'ClipBoardData
     
190.            )
     
191.            'setData
     
192.            "Text"
     
193.            str
     
194.          )
     
195.   )
     
196.   (vlax-release-object html)
     
197.   str
     
198.       )
     
199.     )          ;end if
     
200.   )
     
201.   (defun zx-getfolder (msg dir bit / err fld pth shl slf hwd)
     
202.           ;浏览目录，获取目录，指定目录，目录路径
     
203.           ; Displays a dialog prompting the user to select a folder.
     
204.           ; msg - [str] 提示信息
     
205.           ; dir - [str] 限定用户文件夹路径，可以是nil
     
206.           ; bit - [int] 对话框类型参数，如1 2 4 8 16....
     
207.           ; Returns: [str] Selected folder filepath, else nil.
     
208.     (OR bit (SETQ bit 1))
     
209.     (setq app (vlax-get-acad-object))
     
210.     (setq shl (vl-catch-all-apply
     
211.     'vla-getinterfaceobject
     
212.     (list app "shell.application")
     
213.         )
     
214.     )
     
215.     (setq hwd (vl-catch-all-apply 'vla-get-hwnd (list app)))
     
216.     (if  (vl-catch-all-error-p hwd)
     
217.       (setq hwd 0)
     
218.     )
     
219.     (setq fld (vl-catch-all-apply
     
220.     'vlax-invoke-method
     
221.     (list
     
222.       shl 'browseforfolder hwd msg bit dir)
     
223.         )
     
224.     )
     
225.     (setq slf (vl-catch-all-apply 'vlax-get-property (list fld 'self)))
     
226.     (setq pth (vl-catch-all-apply 'vlax-get-property (list slf 'path)))
     
227.     (setq pth (vl-catch-all-apply
     
228.     'vl-string-translate
     
229.     (list "/" "\\" pth)
     
230.         )
     
231.     )
     
232.     (setq
     
233.       pth (vl-catch-all-apply 'vl-string-right-trim (list "\\" pth))
     
234.     )
     
235.     (vl-catch-all-apply 'vlax-release-object (list slf))
     
236.     (vl-catch-all-apply 'vlax-release-object (list fld))
     
237.     (vl-catch-all-apply 'vlax-release-object (list shl))
     
238.     (if  (vl-catch-all-error-p pth)
     
239.       (progn (PRINT (vl-catch-all-error-message pth)) nil)
     
240.       pth
     
241.     )
     
242.   )
     
243.   (defun merge-str-by-bar (strlst bar / str len bars str-last)
     
244.           ;拼接子串，列表转子串
     
245.     (if  (and strlst
     
246.        bar
     
247.        (= (type strlst) 'list)
     
248.        (setq strlst (vl-remove nil strlst))
     
249.        (= (type (CAR strlst)) 'STR)
     
250.        (= (type bar) 'str)
     
251.   )
     
252.       (progn
     
253.   (setq str-last (last strlst))
     
254.   (setq str-bar
     
255.          (mapcar
     
256.      (function (lambda (a)
     
257.            (or (and a (= (type a) 'str)) (setq a ""))
     
258.            (strcat a bar)
     
259.          )
     
260.      )
     
261.      (reverse (cdr (reverse strlst)))
     
262.          )
     
263.   )
     
264.   (setq str (apply 'strcat str-bar))
     
265.   (setq str (strcat str str-last))
     
266.       )
     
267.     )
     
268.     str
     
269.   )
     
270.   (defun delsame (lst / s-car new)
     
271.           ;删除表中重复项，删除重复
     
272.     (setq lst (vl-remove nil lst))
     
273.     (while (setq s-car (car lst))
     
274.       (if (vl-position s-car new)
     
275.   ()
     
276.   (setq new (cons s-car new))
     
277.       )
     
278.       (setq lst (cdr lst))
     
279.     )
     
280.     (setq new (reverse new))
     
281.     new
     
282.   )
     
283.   (setq file (zx-getfolder "请选择目录开始统计图层" nil 256))
     
284.   (setq  dwgs ($lie-chu-mu-lu-xia-suo-you-wen-jian$
     
285.          (list
     
286.      (cons
     
287.        "目录"
     
288.        file
     
289.      )
     
290.      (cons "扩展名" "*.dwg")
     
291.          )
     
292.        )
     
293.   )
     
294.   (SETQ dwgs (APPLY 'APPEND dwgs))
     
295.   (SETQ  TCS (MAPCAR (FUNCTION (LAMBDA (A)
     
296.         (get-text-style-all-dbx A)
     
297.             )
     
298.         )
     
299.         DWGS
     
300.       )
     
301.   )
     
302.   (SETQ TCS (APPLY 'APPEND TCS))
     
303.   (SETQ TCS (delsame TCS))
     
304.   (setClipText (merge-str-by-bar tcs "\n"))
     
305.   (alert "已经放到剪切板了，您可以粘贴到其它软件了")
     
306. )

(DEFUN C:TCTJ (/<br />          $lie-chu-mu-lu-xia-suo-you-wen-jian$<br />          delsame          dwgs<br />          file          get-text-style-all-dbx<br />          merge-str-by-bar        setcliptext<br />          tcs          zx-getfolder<br />         )<br />   (defun get-text-style-all-dbx  (dwg    /     *error*<br />          _getattributes     app      dbx<br />          dir    doc     dwl      err<br />          rtn    vrs     dwg-n    open-zt<br />          MACRO    pt<br />         )<br />           ;使用dbx读取外部dwg里面的所有属性块的属性<br />     (defun *error* (msg)<br />       (if (and (= 'vla-object (type dbx))<br />          (not (vlax-object-released-p dbx))<br />     )<br />   (vlax-release-object dbx)<br />       )<br />       (vl-catch-all-apply (function (lambda () (c:var nil nil))))<br />           ;强制将变量还原<br />       (princ)<br />     )<br />     (defun get-text-style (doc / n ns obj)<br />       (SETQ MACRO "█")<br />       (sETVAR "modemacro" MACRO)<br />       (setq ns nil)<br />       (vlax-for  obj (vla-get-LAYERs doc)<br />   (setq n (vla-get-name obj))<br />   (setq ns (cons n ns))<br />       )<br />       ns<br />     )<br />     (if  (and dwg (findfile dwg))<br />       (cond<br />   ((progn<br />      (setq dbx<br />       (vl-catch-all-apply<br />         'vla-getinterfaceobject<br />         (list (setq app (vlax-get-acad-object))<br />         (if (< (setq vrs (atoi (getvar 'acadver))) 16)<br />           "objectdbx.axdbdocument"<br />           (strcat "objectdbx.axdbdocument." (itoa vrs))<br />         )<br />         )<br />       )<br />      )<br />      (or (null dbx) (vl-catch-all-error-p dbx))<br />    )<br />    (prompt "调用dbx组件失败，请重装完整版cad")<br />   )<br />   (t<br />    (vlax-for doc (vla-get-documents app)<br />      (setq<br />        dwl<br />         (cons (cons (strcase (vla-get-fullname doc)) doc) dwl)<br />      )<br />    )<br />    (and (vl-file-copy<br />     dwg<br />     (setq dwg-n (vl-filename-mktemp "1.dwg"))<br />         )        ;复制一个dwg再打开<br />         (setq dwg dwg-n)<br />         (setq<br />     open-zt  (vl-catch-all-error-p<br />         (vl-catch-all-apply 'vla-open (list dbx dwg))<br />       )<br />         )<br />         (not (vl-catch-all-error-p open-zt))<br />    )<br />    (if<br />      (and  (not (vl-catch-all-error-p open-zt))<br />     (setq doc dbx)<br />      )<br />       (progn<br />         (setq rtn<br />          (if (vl-catch-all-error-p<br />          (setq err<br />           (vl-catch-all-apply<br />             (FUNCTION (LAMBDA () (get-text-style doc)))<br />           )<br />          )<br />        )<br />            (progn (print)<br />             (princ dwg)<br />             (princ "   ")<br />             (princ (vl-catch-all-error-message err))<br />            )<br />            err<br />          )<br />         )<br />       )<br />       (princ (strcat "dwg打开失败了: "<br />          (vl-filename-base dwg)<br />          ".dwg"<br />        )<br />       )<br />    )<br />    (if (= 'vla-object (type dbx))<br />      (vlax-release-object dbx)<br />    )<br />    (vl-catch-all-apply<br />      (FUNCTION (LAMBDA () (vl-file-delete dwg-n)))<br />           ;删除复制的文件<br />    )<br />    rtn<br />   )<br />       )<br />     )<br />     (sETVAR "modemacro" "中线CAD")<br />     rtn<br />   )<br />   (defun $lie-chu-mu-lu-xia-suo-you-wen-jian$<br />    (lst / a f fs fs-all kzm n ns ns-1 wj wjs)<br />           ;列出目录下所有文件，含子级目录，所有目录下的文件<br />           ;示例<img src="static/image/smiley/default/sad.gif" smilieid="2" border="0" alt="" />$lie-chu-mu-lu-xia-suo-you-wen-jian$(list(cons "目录" "C:\\uploads")(cons "扩展名" "*.dwg")))<br />     (or  (and lst<br />        (= (type lst) 'list)<br />        (setq kzm (cdr (assoc "扩展名" lst)))<br />        (> (strlen kzm) 0)<br />        (wcmatch kzm "[,`*.*,]")<br />   )<br />   (setq kzm "*.*")<br />     )<br />     (or  (and lst<br />        (= (type lst) 'list)<br />        (setq f (cdr (assoc "目录" lst)))<br />   )<br />   (and lst (= (type lst) 'str) (setq f lst))<br />     )<br />     (and<br />       f<br />       kzm<br />       (findfile f)<br />       (progn<br />   (while (and f (wcmatch f "*`\\*"))<br />     (setq f (vl-string-subst "/" "\\" f))<br />   )<br />   (setq fs-all nil)<br />   (setq fs-all (cons f fs-all))<br />   (setq fs (vl-directory-files f "*.*" -1))<br />   (setq fs (vl-remove ".." fs))<br />   (setq fs (vl-remove "." fs))<br />   (setq fs (mapcar (function (lambda (a) (strcat f "/" a))) fs))<br />   (setq fs-all (APPEND fs-all fs))<br />   (while (AND fs (setq f (last fs)) (< (length fs-all) 10000))<br />     (setq ns nil)<br />     (setq ns (vl-directory-files f "*.*" -1))<br />     (setq ns (vl-remove ".." ns))<br />     (setq ns (vl-remove "." ns))<br />     (while (setq a (car ns))<br />       (setq n (strcat f "/" a))<br />       (setq fs (cons n fs))<br />       (setq fs-all (cons n fs-all))<br />       (setq ns (cdr ns))<br />     )<br />     (setq fs (reverse (cdr (reverse fs))))<br />   )<br />   (and fs-all<br />        (progn<br />          (setq wjs nil)<br />          (while (setq a (car fs-all))<br />      (setq wj nil)<br />      (setq wj (vl-directory-files a kzm 1))<br />      (setq wj (vl-remove ".." wj))<br />      (setq wj (vl-remove "." wj))<br />      (setq<br />        wj<br />         (mapcar (function (lambda (b) (strcat a "/" b))) wj)<br />      )<br />      (setq wjs (cons wj wjs))<br />      (setq fs-all (cdr fs-all))<br />          )<br />          (setq wjs (vl-remove nil wjs))<br />        )<br />   )<br />       )<br />     )<br />     wjs<br />   )<br />   (defun setClipText (str / html result)<br />           ;往剪切板上丢数据<br />     (if  (and str (= 'STR (type str)))<br />       (progn<br />   (setq html   (vlax-create-object "htmlfile")<br />         result (vlax-invoke<br />            (vlax-get (vlax-get html 'ParentWindow)<br />          'ClipBoardData<br />            )<br />            'setData<br />            "Text"<br />            str<br />          )<br />   )<br />   (vlax-release-object html)<br />   str<br />       )<br />     )          ;end if<br />   )<br />   (defun zx-getfolder (msg dir bit / err fld pth shl slf hwd)<br />           ;浏览目录，获取目录，指定目录，目录路径<br />           ; Displays a dialog prompting the user to select a folder.<br />           ; msg - [str] 提示信息<br />           ; dir - [str] 限定用户文件夹路径，可以是nil<br />           ; bit - [int] 对话框类型参数，如1 2 4 8 16....<br />           ; Returns: [str] Selected folder filepath, else nil.<br />     (OR bit (SETQ bit 1))<br />     (setq app (vlax-get-acad-object))<br />     (setq shl (vl-catch-all-apply<br />     'vla-getinterfaceobject<br />     (list app "shell.application")<br />         )<br />     )<br />     (setq hwd (vl-catch-all-apply 'vla-get-hwnd (list app)))<br />     (if  (vl-catch-all-error-p hwd)<br />       (setq hwd 0)<br />     )<br />     (setq fld (vl-catch-all-apply<br />     'vlax-invoke-method<br />     (list<br />       shl 'browseforfolder hwd msg bit dir)<br />         )<br />     )<br />     (setq slf (vl-catch-all-apply 'vlax-get-property (list fld 'self)))<br />     (setq pth (vl-catch-all-apply 'vlax-get-property (list slf 'path)))<br />     (setq pth (vl-catch-all-apply<br />     'vl-string-translate<br />     (list "/" "\\" pth)<br />         )<br />     )<br />     (setq<br />       pth (vl-catch-all-apply 'vl-string-right-trim (list "\\" pth))<br />     )<br />     (vl-catch-all-apply 'vlax-release-object (list slf))<br />     (vl-catch-all-apply 'vlax-release-object (list fld))<br />     (vl-catch-all-apply 'vlax-release-object (list shl))<br />     (if  (vl-catch-all-error-p pth)<br />       (progn (PRINT (vl-catch-all-error-message pth)) nil)<br />       pth<br />     )<br />   )<br />   (defun merge-str-by-bar (strlst bar / str len bars str-last)<br />           ;拼接子串，列表转子串<br />     (if  (and strlst<br />        bar<br />        (= (type strlst) 'list)<br />        (setq strlst (vl-remove nil strlst))<br />        (= (type (CAR strlst)) 'STR)<br />        (= (type bar) 'str)<br />   )<br />       (progn<br />   (setq str-last (last strlst))<br />   (setq str-bar<br />          (mapcar<br />      (function (lambda (a)<br />            (or (and a (= (type a) 'str)) (setq a ""))<br />            (strcat a bar)<br />          )<br />      )<br />      (reverse (cdr (reverse strlst)))<br />          )<br />   )<br />   (setq str (apply 'strcat str-bar))<br />   (setq str (strcat str str-last))<br />       )<br />     )<br />     str<br />   )<br />   (defun delsame (lst / s-car new)<br />           ;删除表中重复项，删除重复<br />     (setq lst (vl-remove nil lst))<br />     (while (setq s-car (car lst))<br />       (if (vl-position s-car new)<br />   ()<br />   (setq new (cons s-car new))<br />       )<br />       (setq lst (cdr lst))<br />     )<br />     (setq new (reverse new))<br />     new<br />   )<br />   (setq file (zx-getfolder "请选择目录开始统计图层" nil 256))<br />   (setq  dwgs ($lie-chu-mu-lu-xia-suo-you-wen-jian$<br />          (list<br />      (cons<br />        "目录"<br />        file<br />      )<br />      (cons "扩展名" "*.dwg")<br />          )<br />        )<br />   )<br />   (SETQ dwgs (APPLY 'APPEND dwgs))<br />   (SETQ  TCS (MAPCAR (FUNCTION (LAMBDA (A)<br />         (get-text-style-all-dbx A)<br />             )<br />         )<br />         DWGS<br />       )<br />   )<br />   (SETQ TCS (APPLY 'APPEND TCS))<br />   (SETQ TCS (delsame TCS))<br />   (setClipText (merge-str-by-bar tcs "\n"))<br />   (alert "已经放到剪切板了，您可以粘贴到其它软件了")<br /> )

黄翔

谢谢分享.

p-3-ianlcc

谢谢大佬的分享！
很棒的资料

raimo

大佬能不能写一个这种程序？

http://bbs.mjtd.com/thread-191012-1-1.html

jkop

图层名称汇出，主要用来检视制图者的设计分类，也可能会用到，收藏！

czb203

感谢大佬的分享，精品