乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 ☆ ☆ ☆ 尊重版权，从我做起，拒绝盗版，拒绝倒卖 ☆ ☆ ☆ 签到、发布资源、邀请好友注册，可以获得银币 ☆ ☆ ☆ 请注意保管好自己的密码，避免账户资金被盗
楼主: AQucsaiJr

[编程交流] 在多个Dra中列出图层

[复制链接]
Lee Mac

114

主题

1万

帖子

1万

银币

中流砥柱

Rank: 25

铜币
543
发表于 2022-7-5 17:17:22 | 显示全部楼层
这个怎么样？
 
  2. (defun c:CheckLayers (/ *error* ObjRelease DirDialog Get_Subs ObjectDBXDocument GetLayers Str-Make
  4.                        DBX DOCLST DWLST FILE FOLDER LAYER_LIST PATH SHELL)
  5.  (vl-load-com)
  6.  ;; Lee Mac  ~  15.01.10
  7.  
  9.  (defun *error* (msg)
  10.    (ObjRelease (list Shell dbx))
  11.    (and ofile (= (type ofile) 'FILE) (close ofile))
  12.    
  13.    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
  14.        (princ (strcat "\n** Error: " msg " **")))
  15.    (princ))
  18.  (defun ObjRelease (lst)
  19.    (mapcar
  20.      (function
  21.        (lambda (x)
  22.          (if (and (eq (type x) 'VLA-OBJECT)
  23.                   (not (vlax-object-released-p x)))
  24.            (vl-catch-all-apply
  25.              (function vlax-release-object) (list x))))) lst))
  28.  (defun DirDialog (msg dir flag / Shell Fold Path)
  29.    ;; Lee Mac  ~  07.06.09
  30.    
  31.    (setq Shell (vla-getInterfaceObject *acad "Shell.Application")
  32.          Fold  (vlax-invoke-method Shell 'BrowseForFolder
  33.                  (vla-get-HWND *acad) msg flag dir))
  34.    (vlax-release-object Shell)
  35.    
  36.    (if Fold
  37.      (progn
  38.        (setq Path (vlax-get-property
  39.                     (vlax-get-property Fold 'Self) 'Path))
  40.        (vlax-release-object Fold)
  41.        
  42.        (and (= "\" (substr Path (strlen Path)))
  43.             (setq Path (substr Path 1 (1- (strlen Path)))))))
  44.    
  45.    Path) 
  48.  (defun Get_Subs (folder / file) ;; CAB
  49.    (mapcar
  50.      (function
  51.        (lambda (x) (setq file (strcat folder "\" x))
  52.                    (cons file (apply (function append) (get_subs file)))))
  53.        (cddr (vl-directory-files folder nil -1))))
  55.  
  56.  (defun ObjectDBXDocument (/ acVer)
  57.    
  58.    (vla-GetInterfaceObject *acad
  59.      (if (< (setq acVer (atoi (getvar "ACADVER"))) 16) "ObjectDBX.AxDbDocument"
  60.        (strcat "ObjectDBX.AxDbDocument." (itoa acVer)))))
  61.  
  63.  (defun GetLayerProperties (doc / lst)
  64.    (vlax-for lay (vla-get-Layers doc)
  65.      (setq lst (cons
  66.                  (mapcar
  67.                    (function
  68.                      (lambda (property)
  69.                        (vl-princ-to-string
  70.                          (vlax-get-property lay property))))
  72.                    '(Name Color Linetype LineWeight))
  74.                  lst)))
  75.    
  76.    (vl-sort lst
  77.      (function
  78.        (lambda (a b) (< (car a) (car b))))))
  80.  
  81.  (defun Str-Make (lst del / Pad str x)
  83.    (defun Pad (pStr pDel Len)
  84.      (while (< (strlen pStr) Len)
  85.        (setq pStr (strcat pStr pDel)))
  86.      pStr)
  87.    
  88.    (setq str  (Pad (car lst) (chr 32) 30))
  89.    (foreach x (cdr lst)
  90.      (setq str (strcat Str Del (Pad x (chr 32) 30))))
  91.    
  92.  str)
  93.  
  95.  (setq *acad (cond (*acad) ((vlax-get-acad-object)))
  96.        *doc  (cond (*doc ) ((vla-get-ActiveDocument *acad))))
  98.  (or *def* (setq *def* "Yes"))
  99.  
  101.  (if (and (setq Path (DirDialog "Select Directory" nil 0))
  102.           (vl-file-directory-p Path)
  103.           (setq outfile (getfiled "Output File" "" "txt" 1)))
  104.    (progn
  106.      (initget "Yes No")
  107.      (setq *def* (cond ((getkword
  108.                           (strcat "\nProcess SubDirectories? <" *def* "> : "))) (*def*)))
  110.      (vlax-for doc (vla-get-Documents *acad)
  111.        (setq DocLst (cons (cons (vla-get-FullName doc) doc) DocLst)))
  112.      
  114.      (foreach dwg  (setq dwLst (apply (function append)
  115.                                       (vl-remove 'nil
  116.                                         (mapcar
  117.                                           (function
  118.                                             (lambda (Path)
  119.                                               (mapcar
  120.                                                 (function
  121.                                                   (lambda (File)
  122.                                                     (strcat Path "\" File)))
  123.                                                 (vl-directory-files Path "*.dwg" 1))))
  124.                                           (append (list Path)
  125.                                                   (apply (function append)
  126.                                                          (if (= "YES" (strcase *def*))
  127.                                                            (Get_Subs Path))))))))
  129.        (setq dbx (cdr (assoc dwg DocLst)))        
  131.        (and (not dbx) (setq dbx (ObjectDBXDocument)))
  132.        
  134.        (if (not (vl-catch-all-error-p
  135.                    (vl-catch-all-apply
  136.                      (function vla-open) (list dbx dwg))))
  138.          (setq Layer_List (cons (cons dwg (GetLayerProperties dbx)) Layer_List))))
  140.      (princ (strcat "\n<< " (itoa (length dwLst)) " Drawings Processed >>")))
  141.    
  142.    (princ "*Cancel*"))
  144.  (ObjRelease (list Shell dbx)) (gc) (gc)
  146.  (if (and Layer_List
  147.          (setq ofile (open outfile "w")))
  148.    (progn
  149.      
  150.      (mapcar
  151.        (function
  152.          (lambda (x)
  153.            (write-line (car x) ofile)
  154.            (write-line (Str-Make '("Name" "Colour" "LineType" "LineWeight") (chr 32)) ofile)
  155.            (mapcar
  156.              (function
  157.                (lambda (y)
  158.                  (write-line
  159.                    (Str-Make y (chr 32)) ofile))) (cdr x))
  160.            
  161.            (write-line "\n" ofile)))
  163.        Layer_List)
  165.      (close ofile))
  167.    (princ "\n*Cancel*"))
  169.  (princ))
回复

使用道具 举报

AQucsaiJr

36

主题

183

帖子

151

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
185
发表于 2022-7-5 17:22:17 | 显示全部楼层
哦。。。真是太好了！
回复

使用道具 举报

Lee Mac

114

主题

1万

帖子

1万

银币

中流砥柱

Rank: 25

铜币
543
发表于 2022-7-5 17:23:28 | 显示全部楼层
这具有更好的间距功能：
 
  2. (defun c:CheckLayers (/ *error* ObjRelease DirDialog Get_Subs ObjectDBXDocument GetLayers Str-Make
  4.                        DBX DOCLST DWLST FILE FOLDER LAYER_LIST PATH SHELL)
  5.  (vl-load-com)
  6.  ;; Lee Mac  ~  15.01.10
  7.  
  9.  (defun *error* (msg)
  10.    (ObjRelease (list Shell dbx))
  11.    (and ofile (= (type ofile) 'FILE) (close ofile))
  12.    
  13.    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
  14.        (princ (strcat "\n** Error: " msg " **")))
  15.    (princ))
  18.  (defun ObjRelease (lst)
  19.    (mapcar
  20.      (function
  21.        (lambda (x)
  22.          (if (and (eq (type x) 'VLA-OBJECT)
  23.                   (not (vlax-object-released-p x)))
  24.            (vl-catch-all-apply
  25.              (function vlax-release-object) (list x))))) lst))
  28.  (defun DirDialog (msg dir flag / Shell Fold Path)
  29.    ;; Lee Mac  ~  07.06.09
  30.    
  31.    (setq Shell (vla-getInterfaceObject *acad "Shell.Application")
  32.          Fold  (vlax-invoke-method Shell 'BrowseForFolder
  33.                  (vla-get-HWND *acad) msg flag dir))
  34.    (vlax-release-object Shell)
  35.    
  36.    (if Fold
  37.      (progn
  38.        (setq Path (vlax-get-property
  39.                     (vlax-get-property Fold 'Self) 'Path))
  40.        (vlax-release-object Fold)
  41.        
  42.        (and (= "\" (substr Path (strlen Path)))
  43.             (setq Path (substr Path 1 (1- (strlen Path)))))))
  44.    
  45.    Path) 
  48.  (defun Get_Subs (folder / file) ;; CAB
  49.    (mapcar
  50.      (function
  51.        (lambda (x) (setq file (strcat folder "\" x))
  52.                    (cons file (apply (function append) (get_subs file)))))
  53.        (cddr (vl-directory-files folder nil -1))))
  55.  
  56.  (defun ObjectDBXDocument (/ acVer)
  57.    
  58.    (vla-GetInterfaceObject *acad
  59.      (if (< (setq acVer (atoi (getvar "ACADVER"))) 16) "ObjectDBX.AxDbDocument"
  60.        (strcat "ObjectDBX.AxDbDocument." (itoa acVer)))))
  61.  
  63.  (defun GetLayerProperties (doc / lst)
  64.    (vlax-for lay (vla-get-Layers doc)
  65.      (setq lst (cons
  66.                  (mapcar
  67.                    (function
  68.                      (lambda (property)
  69.                        (vl-princ-to-string
  70.                          (vlax-get-property lay property))))
  72.                    '(Name Color Linetype LineWeight))
  74.                  lst)))
  75.    
  76.    (vl-sort lst
  77.      (function
  78.        (lambda (a b) (< (car a) (car b))))))
  80.  
  81.  (defun Str-Make  (lst del / Pad str x i)
  82.    (setq i 10)
  84.    (defun Pad  (Str Del Len)
  85.      (while (>= (strlen Str) Len) (setq Len (+ Len 5)))
  86.      (while (< (strlen Str) Len)
  87.        (setq Str (strcat Str Del)))
  88.      Str)
  90.    (apply (function strcat)
  91.           (reverse
  92.             (cons (last lst)
  93.                   (mapcar
  94.                     (function
  95.                       (lambda ($str)
  96.                         (Pad $str del
  97.                              (setq i (abs (- 40 i))))))
  99.                     (cdr (reverse lst)))))))
  100.    
  102.  (setq *acad (cond (*acad) ((vlax-get-acad-object)))
  103.        *doc  (cond (*doc ) ((vla-get-ActiveDocument *acad))))
  105.  (or *def* (setq *def* "Yes"))
  106.  
  108.  (if (and (setq Path (DirDialog "Select Directory" nil 0))
  109.           (vl-file-directory-p Path)
  110.           (setq outfile (getfiled "Output File" "" "txt" 1)))
  111.    (progn
  113.      (initget "Yes No")
  114.      (setq *def* (cond ((getkword
  115.                           (strcat "\nProcess SubDirectories? <" *def* "> : "))) (*def*)))
  117.      (vlax-for doc (vla-get-Documents *acad)
  118.        (setq DocLst
  119.          (cons (cons (strcase (vla-get-FullName doc)) doc) DocLst)))
  120.      
  122.      (foreach dwg (setq dwLst (apply (function append)
  123.                                       (vl-remove 'nil
  124.                                         (mapcar
  125.                                           (function
  126.                                             (lambda (Path)
  127.                                               (mapcar
  128.                                                 (function
  129.                                                   (lambda (File)
  130.                                                     (strcat Path "\" File)))
  131.                                                 (vl-directory-files Path "*.dwg" 1))))
  132.                                           (append (list Path)
  133.                                                   (apply (function append)
  134.                                                          (if (= "YES" (strcase *def*))
  135.                                                            (Get_Subs Path))))))))
  137.        (setq dbx (cdr (assoc (strcase dwg) DocLst)))        
  139.        (and (not dbx) (setq dbx (ObjectDBXDocument)))
  140.        
  142.        (if (not (vl-catch-all-error-p
  143.                    (vl-catch-all-apply
  144.                      (function vla-open) (list dbx dwg))))
  146.          (setq Layer_List (cons (cons dwg (GetLayerProperties dbx)) Layer_List))
  147.          (setq Layer_List (cons (cons dwg '(("**Error Opening this Drawing **"))) Layer_List))))
  148.                
  150.      (princ (strcat "\n<< " (itoa (length dwLst)) " Drawings Processed >>")))
  151.    
  152.    (princ "*Cancel*"))
  154.  (ObjRelease (list Shell dbx)) (gc) (gc)
  156.  (if (and Layer_List
  157.          (setq ofile (open outfile "w")))
  158.    (progn
  159.      
  160.      (mapcar
  161.        (function
  162.          (lambda (x)
  163.            (write-line (car x) ofile)
  164.            (write-line (Str-Make '("Name" "Colour" "LineType" "LineWeight") (chr 32)) ofile)
  165.            (mapcar
  166.              (function
  167.                (lambda (y)
  168.                  (write-line
  169.                    (Str-Make y (chr 32)) ofile))) (cdr x))
  170.            
  171.            (write-line "\n" ofile)))
  173.        Layer_List)
  175.      (close ofile))
  177.    (princ "\n*Cancel*"))
  179.  (princ))
回复

使用道具 举报

MihaiT

0

主题

1

帖子

1

银币

初来乍到

Rank: 1

铜币
0
发表于 2022-7-5 17:31:47 | 显示全部楼层
这真是一部了不起的作品冲击：
李是你的超级粉丝。
重新播放代码为我节省了很多时间。但是我想知道你是否可以帮我把代码设置成忽略所有外部参照。
回复

使用道具 举报

Lee Mac

114

主题

1万

帖子

1万

银币

中流砥柱

Rank: 25

铜币
543
发表于 2022-7-5 17:35:01 | 显示全部楼层
 
谢谢你的客气话MihaiT，欢迎来到CADTutor。
 
这个线程包含一些非常旧的代码该程序后来发展成为我的图层提取器应用程序，它提供了从输出中包括/排除外部参照相关图层的选项。
 
我很高兴你发现代码很有用！
 
李
回复

使用道具 举报

12
返回列表 发帖

发表回复

高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

精选推荐

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-8-21 01:57 , Processed in 1.491609 second(s), 71 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表