(defun c:CheckLayers (/ *error* ObjRelease DirDialog Get_Subs ObjectDBXDocument GetLayers Str-Make
DBX DOCLST DWLST FILE FOLDER LAYER_LIST PATH SHELL)
(vl-load-com)
;; Lee Mac~15.01.10
(defun *error* (msg)
(ObjRelease (list Shell dbx))
(and ofile (= (type ofile) 'FILE) (close ofile))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ))
(defun ObjRelease (lst)
(mapcar
(function
(lambda (x)
(if (and (eq (type x) 'VLA-OBJECT)
(not (vlax-object-released-p x)))
(vl-catch-all-apply
(function vlax-release-object) (list x))))) lst))
(defun DirDialog (msg dir flag / Shell Fold Path)
;; Lee Mac~07.06.09
(setq Shell (vla-getInterfaceObject *acad "Shell.Application")
Fold(vlax-invoke-method Shell 'BrowseForFolder
(vla-get-HWND *acad) msg flag dir))
(vlax-release-object Shell)
(if Fold
(progn
(setq Path (vlax-get-property
(vlax-get-property Fold 'Self) 'Path))
(vlax-release-object Fold)
(and (= "\\" (substr Path (strlen Path)))
(setq Path (substr Path 1 (1- (strlen Path)))))))
Path)
(defun Get_Subs (folder / file) ;; CAB
(mapcar
(function
(lambda (x) (setq file (strcat folder "\\" x))
(cons file (apply (function append) (get_subs file)))))
(cddr (vl-directory-files folder nil -1))))
(defun ObjectDBXDocument (/ acVer)
(vla-GetInterfaceObject *acad
(if (< (setq acVer (atoi (getvar "ACADVER"))) 16) "ObjectDBX.AxDbDocument"
(strcat "ObjectDBX.AxDbDocument." (itoa acVer)))))
(defun GetLayerProperties (doc / lst)
(vlax-for lay (vla-get-Layers doc)
(setq lst (cons
(mapcar
(function
(lambda (property)
(vl-princ-to-string
(vlax-get-property lay property))))
'(Name Color Linetype LineWeight))
lst)))
(vl-sort lst
(function
(lambda (a b) (< (car a) (car b))))))
(defun Str-Make (lst del / Pad str x)
(defun Pad (pStr pDel Len)
(while (< (strlen pStr) Len)
(setq pStr (strcat pStr pDel)))
pStr)
(setq str(Pad (car lst) (chr 32) 30))
(foreach x (cdr lst)
(setq str (strcat Str Del (Pad x (chr 32) 30))))
str)
(setq *acad (cond (*acad) ((vlax-get-acad-object)))
*doc(cond (*doc ) ((vla-get-ActiveDocument *acad))))
(or *def* (setq *def* "Yes"))
(if (and (setq Path (DirDialog "Select Directory" nil 0))
(vl-file-directory-p Path)
(setq outfile (getfiled "Output File" "" "txt" 1)))
(progn
(initget "Yes No")
(setq *def* (cond ((getkword
(strcat "\nProcess SubDirectories? <" *def* "> : "))) (*def*)))
(vlax-for doc (vla-get-Documents *acad)
(setq DocLst (cons (cons (vla-get-FullName doc) doc) DocLst)))
(foreach dwg(setq dwLst (apply (function append)
(vl-remove 'nil
(mapcar
(function
(lambda (Path)
(mapcar
(function
(lambda (File)
(strcat Path "\\" File)))
(vl-directory-files Path "*.dwg" 1))))
(append (list Path)
(apply (function append)
(if (= "YES" (strcase *def*))
(Get_Subs Path))))))))
(setq dbx (cdr (assoc dwg DocLst)))
(and (not dbx) (setq dbx (ObjectDBXDocument)))
(if (not (vl-catch-all-error-p
(vl-catch-all-apply
(function vla-open) (list dbx dwg))))
(setq Layer_List (cons (cons dwg (GetLayerProperties dbx)) Layer_List))))
(princ (strcat "\n<< " (itoa (length dwLst)) " Drawings Processed >>")))
(princ "*Cancel*"))
(ObjRelease (list Shell dbx)) (gc) (gc)
(if (and Layer_List
(setq ofile (open outfile "w")))
(progn
(mapcar
(function
(lambda (x)
(write-line (car x) ofile)
(write-line (Str-Make '("Name" "Colour" "LineType" "LineWeight") (chr 32)) ofile)
(mapcar
(function
(lambda (y)
(write-line
(Str-Make y (chr 32)) ofile))) (cdr x))
(write-line "\n" ofile)))
Layer_List)
(close ofile))
(princ "\n*Cancel*"))
(princ))
哦。。。真是太好了！ 这具有更好的间距功能：
(defun c:CheckLayers (/ *error* ObjRelease DirDialog Get_Subs ObjectDBXDocument GetLayers Str-Make
DBX DOCLST DWLST FILE FOLDER LAYER_LIST PATH SHELL)
(vl-load-com)
;; Lee Mac~15.01.10
(defun *error* (msg)
(ObjRelease (list Shell dbx))
(and ofile (= (type ofile) 'FILE) (close ofile))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ))
(defun ObjRelease (lst)
(mapcar
(function
(lambda (x)
(if (and (eq (type x) 'VLA-OBJECT)
(not (vlax-object-released-p x)))
(vl-catch-all-apply
(function vlax-release-object) (list x))))) lst))
(defun DirDialog (msg dir flag / Shell Fold Path)
;; Lee Mac~07.06.09
(setq Shell (vla-getInterfaceObject *acad "Shell.Application")
Fold(vlax-invoke-method Shell 'BrowseForFolder
(vla-get-HWND *acad) msg flag dir))
(vlax-release-object Shell)
(if Fold
(progn
(setq Path (vlax-get-property
(vlax-get-property Fold 'Self) 'Path))
(vlax-release-object Fold)
(and (= "\\" (substr Path (strlen Path)))
(setq Path (substr Path 1 (1- (strlen Path)))))))
Path)
(defun Get_Subs (folder / file) ;; CAB
(mapcar
(function
(lambda (x) (setq file (strcat folder "\\" x))
(cons file (apply (function append) (get_subs file)))))
(cddr (vl-directory-files folder nil -1))))
(defun ObjectDBXDocument (/ acVer)
(vla-GetInterfaceObject *acad
(if (< (setq acVer (atoi (getvar "ACADVER"))) 16) "ObjectDBX.AxDbDocument"
(strcat "ObjectDBX.AxDbDocument." (itoa acVer)))))
(defun GetLayerProperties (doc / lst)
(vlax-for lay (vla-get-Layers doc)
(setq lst (cons
(mapcar
(function
(lambda (property)
(vl-princ-to-string
(vlax-get-property lay property))))
'(Name Color Linetype LineWeight))
lst)))
(vl-sort lst
(function
(lambda (a b) (< (car a) (car b))))))
(defun Str-Make(lst del / Pad str x i)
(setq i 10)
(defun Pad(Str Del Len)
(while (>= (strlen Str) Len) (setq Len (+ Len 5)))
(while (< (strlen Str) Len)
(setq Str (strcat Str Del)))
Str)
(apply (function strcat)
(reverse
(cons (last lst)
(mapcar
(function
(lambda ($str)
(Pad $str del
(setq i (abs (- 40 i))))))
(cdr (reverse lst)))))))
(setq *acad (cond (*acad) ((vlax-get-acad-object)))
*doc(cond (*doc ) ((vla-get-ActiveDocument *acad))))
(or *def* (setq *def* "Yes"))
(if (and (setq Path (DirDialog "Select Directory" nil 0))
(vl-file-directory-p Path)
(setq outfile (getfiled "Output File" "" "txt" 1)))
(progn
(initget "Yes No")
(setq *def* (cond ((getkword
(strcat "\nProcess SubDirectories? <" *def* "> : "))) (*def*)))
(vlax-for doc (vla-get-Documents *acad)
(setq DocLst
(cons (cons (strcase (vla-get-FullName doc)) doc) DocLst)))
(foreach dwg (setq dwLst (apply (function append)
(vl-remove 'nil
(mapcar
(function
(lambda (Path)
(mapcar
(function
(lambda (File)
(strcat Path "\\" File)))
(vl-directory-files Path "*.dwg" 1))))
(append (list Path)
(apply (function append)
(if (= "YES" (strcase *def*))
(Get_Subs Path))))))))
(setq dbx (cdr (assoc (strcase dwg) DocLst)))
(and (not dbx) (setq dbx (ObjectDBXDocument)))
(if (not (vl-catch-all-error-p
(vl-catch-all-apply
(function vla-open) (list dbx dwg))))
(setq Layer_List (cons (cons dwg (GetLayerProperties dbx)) Layer_List))
(setq Layer_List (cons (cons dwg '(("**Error Opening this Drawing **"))) Layer_List))))
(princ (strcat "\n<< " (itoa (length dwLst)) " Drawings Processed >>")))
(princ "*Cancel*"))
(ObjRelease (list Shell dbx)) (gc) (gc)
(if (and Layer_List
(setq ofile (open outfile "w")))
(progn
(mapcar
(function
(lambda (x)
(write-line (car x) ofile)
(write-line (Str-Make '("Name" "Colour" "LineType" "LineWeight") (chr 32)) ofile)
(mapcar
(function
(lambda (y)
(write-line
(Str-Make y (chr 32)) ofile))) (cdr x))
(write-line "\n" ofile)))
Layer_List)
(close ofile))
(princ "\n*Cancel*"))
(princ))
这真是一部了不起的作品冲击：
李是你的超级粉丝。
重新播放代码为我节省了很多时间。但是我想知道你是否可以帮我把代码设置成忽略所有外部参照。
谢谢你的客气话MihaiT，欢迎来到CADTutor。
这个线程包含一些非常旧的代码该程序后来发展成为我的图层提取器应用程序，它提供了从输出中包括/排除外部参照相关图层的选项。
我很高兴你发现代码很有用！
李
页:
1
[2]