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