求编程：多个cad图内有多个图层，现在想要批量将所有文件按图层写出

shiyj

求编程：有一批cad图，内有多个图层，现在想要批量处理，将所有文件按图层写到新的文件，命名规则如：原CAD文件名+图层名.dwg。

yanshengjiang

然后贴上我在2011年初学时候东拼西凑的一个源码

;;;2011年11月8日 15:10:01
;;;yanshengjiang收集整理
(defun c:tcsc(/ *ERROR* la leng n dwgname lu2 lu work dwgname-lujing wenjian-ls ss);;按图层输出到文件
  (defun *ERROR*(msg)(princ))
    (setvar "cmdecho" 0)
  (INITGET "All Sng")
  (setq work(getkword "\n[全图输出(A)/单一图层输出(S)]    默认(S)"))
         (if (/= "" work)(setq work "All"))
    (setq la(get_all_layer))
    (setq leng(length la))
    (setq dwgname (getvar "dwgname"))
    (setq dwgname-lujing (getvar "DWGPREFIX"))
    (setq lu2(MAKEFOLDER (strcat dwgname-lujing (vl-filename-base dwgname))))
    (setq lu(strcat  dwgname-lujing (vl-filename-base dwgname)"\\"(vl-filename-base dwgname) "_"))
(if (= "All" work)
    (progn
           (command "_.undo" "m");标记
           (command "_.zoom" "e")
           (command "_.purge" "a" "*" "n")
    (setq n 0)
    (while (< n leng)
    (setq wenjian-ls (strcat lu (nth n la)))
      (if (= nil(findfile(strcat wenjian-ls ".dwg")))
           (if(setq ss (ssget "x" (list(cons 8 (nth n la)))))
       (progn
        (command "_.wblock" wenjian-ls "" "0,0" ss "" "oops")
         (princ "\n已经保存到: ")
         (princ wenjian-ls)
      ))
          (princ (strcat "\n已经存在" wenjian-ls ".dwg"))
      )
      (setq n(1+ n))
    )
      (command "_.undo" "b");后退
      );progn
    (progn
      (setq la(cdr(assoc 8(entget(car(entsel"\n请选择您要输出图层上的一个实体:"))))))
      (setq ss(ssget "x" (list(cons 8 la))))
      (if(= nil(findfile(strcat lu la ".dwg")))
       (progn
        (command "_.undo" "m");标记
        (command "_.zoom" "e")
        (command "_.purge" "a" "*" "n")
        (command "_.wblock" (strcat lu la) "" "0,0" ss "" "oops")
        (command "_.undo" "b");后退
        (princ(strcat"\n已输出到" lu la))
         )
      (princ (strcat "\n已经存在" lu la ".dwg"))
        )
   );progn
  );if
  (princ)
  )


;==========================================================================
  (defun get_all_layer (/ lay layer2 layname);;;;;得到图层列表。。。by秋枫批打
    (setq layer2 nil                       
          lay (tblnext "LAYER" T)
    )
    (while (/= lay nil)
      (setq layname (cdr (assoc 2 lay))
            layer2 (cons layname layer2)
      )
      (setq lay (tblnext "LAYER"))
    )
    (setq layer2 (ACAD_Strlsort layer2))
    layer2                               
   )
;==========================================================================
(defun MAKEFOLDER (FNAME / SYS FOLDER);建立文件夹；;;By LUCAS(龙龙仔)
   (if (not (findfile FNAME))
       (progn
           (setq SYS (vlax-create-object "Scripting.FileSystemObject"))
           (setq FOLDER (vlax-invoke-method SYS 'CREATEFOLDER FNAME))
           (vlax-put  FOLDER
    "Attributes"
    1        ;此处如果改成2.则创建隐藏文件夹
           )
           (vlax-release-object FOLDER)
           (vlax-release-object SYS)
       )
;;;       (alert (strcat "\"" FNAME "\" 档案夹已存在!!"))
   )
   (princ)
)

yanshengjiang

转发z版的一个源码

(vl-load-com)
;按层存文件 明经 ZZXXQQ 2011.1.6 ，nuist 2015.12.18
(defun c:tt ()
  (setvar "CMDECHO" 0)
  (setq lnm nil)
  (setq filepath (strcat (vla-get-Path (vla-get-ActiveDocument (vlax-get-acad-object))) "\\") )
  (setq filepath (strcat (strcat filepath (getvar "dwgname")) "1\\") )
  (command "sh" (strcat "rd/s/q " filepath))
  (command "sh" (strcat "md " filepath))
  (while (setq lnm (tblnext "LAYER" (not lnm)))
    (if (setq ss (ssget "X" (list (cons 8 (cdr(assoc 2 lnm))))))   
      (command ".WBLOCK" (strcat (strcat filepath (cdr(assoc 2 lnm))) ".dxf") "" "" "0,0" ss "")
    )
  )
  (setvar "CMDECHO" 1)
  (princ)
)

shiyj

(defun c:ltt ()
(setvar "CMDECHO" 0)
(setq newpath (strcat (getvar "DWGPREFIX") "out") )
(if (= (vl-file-directory-p newpath)  nil)  (vl-mkdir newpath))
(setq lnm nil)
(while (setq lnm (tblnext "LAYER" (not lnm))  )
  (if (setq ss  (ssget "X"  (list (cons 8 (cdr (assoc 2 lnm) ) )  )  )  )
      (command ".WBLOCK"  (strcat newpath "\\" (vl-filename-base  (getvar  "DWGNAME" )) "-"  (cdr (assoc  2  lnm)))  "" "0,0" ss "" "oops")
        )
)
(setvar "CMDECHO" 1)
(princ)
)

shiyj

yanshengjiang 发表于 2022-12-8 16:16
转发z版的一个源码

(vl-load-com)

感谢回复。之前借鉴Z版代码了，程序不能批处理一个文件夹，还需要用批处理工具，再一个需要打开文件才能处理，速度不是很快。

llsheng_73

1. (defun GetFolder(msg / WinShell shFolder path catchit);选取文件夹
   
2.   (setq shFolder(vlax-invoke-method (vlax-create-object "Shell.Application")'BrowseForFolder 0 msg 1))
   
3.   (setq  catchit(vl-catch-all-apply'(lambda()(setq shFolder(vlax-get-property shFolder'self))
   
4.                                       (setq path(vlax-get-property shFolder'path)))))
   
5.   (if(vl-catch-all-error-p catchit)nil path))
   
6. (defun xdirectory(folder)
   
7.   (setq folder(list(list folder)))
   
8.   (while(car(setq folder(cons(apply'append(mapcar'(lambda(x)(mapcar'(lambda(y)(strcat x"\\"y))(cddr(vl-directory-files X nil -1))))
   
9.                                                  (car folder)))folder))))(apply'append folder))
   
10. (defun getpath(msg ext / path paths files)
    
11.   (and(setq path(GETFOLDER msg))
    
12.       (setq paths(XDIRECTORY path))
    
13.       (setq files(apply'append(mapcar'(lambda(x)(mapcar'(lambda(y)(strcat x "\\"y))(VL-DIRECTORY-FILES x ext 1)))paths)))
    
14.       )(list paths files))
    
15. (defun l2array(l / A)
    
16.   (vlax-safearray-fill(vlax-make-safearray 9(cons 0(1-(length l))))
    
17.     (mapcar(function(lambda(x / a)(setq a(type x))(cond((='ename a)(vlax-ename->vla-object x))((='VLA-OBJECT a)x))))l)))
    
18. (defun c:tt(/ files acad layers *DBX *Dbmdl blk doc blkname acVer)
    
19.   (vl-load-com)
    
20.   (setq acad(vlax-get-acad-object)
    
21.         doc(vlax-get-property acad'activedocument)
    
22.         acVer(atoi(getvar "ACADVER"))
    
23.         *DBX(vla-GetInterfaceObject *ACAD(if(< acVer 16)"ObjectDBX.AxDbDocument"(strcat"ObjectDBX.AxDbDocument."(itoa acVer))))
    
24.         *Dbmdl(vla-get-ModelSpace *dbxobj)
    
25.         blk(vlax-invoke-method(vlax-get-property doc'blocks)'add(vlax-3d-point 0 0)"*U")
    
26.         blkname(vlax-get-property blk'name))
    
27.   (and(setq files(cadr(GETPATH"指定要合并的Excel文件夹""*.dwg")))
    
28.       (vl-some(function(lambda(x / lays la lay)
    
29.                          (vlax-for x blk(vlax-invoke-method x 'delete))
    
30.                          (and(not(VL-CATCH-ALL-ERROR-P(VL-CATCH-ALL-APPLY(function vlax-invoke-method)(List(*DBX"open"x)))))
    
31.                              (vlax-for x(vlax-get-property *DBX'layers)(setq lays(cons(list(vlax-get-property x 'name))lays)))
    
32.                              (vlax-for x *Dbmdl
    
33.                                (setq la(assoc(vlax-get-property x'layer)lays)lays(cons(vl-list*(car la)x(cdr la))(vl-remove la lays))))
    
34.                              (vl-some(function(lambda(a)
    
35.                                                 (and(cadr a)
    
36.                                                     (vlax-invoke-method doc'wblock(strcat(VL-FILENAME-DIRECTORY x)(VL-FILENAME-base x)(car a)".dwg")
    
37.                                                       (vlax-invoke-method *DBX'CopyObjects(l2array(cdr a))))
    
38.                                                     nil)))lays))))
    
39.               files))
    
40.   (vlax-invoke-method blk 'delete))

(defun GetFolder(msg / WinShell shFolder path catchit);选取文件夹<br />   (setq shFolder(vlax-invoke-method (vlax-create-object "Shell.Application")'BrowseForFolder 0 msg 1))<br />   (setq  catchit(vl-catch-all-apply'(lambda()(setq shFolder(vlax-get-property shFolder'self))<br />                                       (setq path(vlax-get-property shFolder'path)))))<br />   (if(vl-catch-all-error-p catchit)nil path))<br /> (defun xdirectory(folder)<br />   (setq folder(list(list folder)))<br />   (while(car(setq folder(cons(apply'append(mapcar'(lambda(x)(mapcar'(lambda(y)(strcat x"\\"y))(cddr(vl-directory-files X nil -1))))<br />                                                  (car folder)))folder))))(apply'append folder))<br /> (defun getpath(msg ext / path paths files)<br />   (and(setq path(GETFOLDER msg))<br />       (setq paths(XDIRECTORY path))<br />       (setq files(apply'append(mapcar'(lambda(x)(mapcar'(lambda(y)(strcat x "\\"y))(VL-DIRECTORY-FILES x ext 1)))paths)))<br />       )(list paths files))<br /> (defun l2array(l / A)<br />   (vlax-safearray-fill(vlax-make-safearray 9(cons 0(1-(length l))))<br />     (mapcar(function(lambda(x / a)(setq a(type x))(cond((='ename a)(vlax-ename->vla-object x))((='VLA-OBJECT a)x))))l)))<br /> (defun c:tt(/ files acad layers *DBX *Dbmdl blk doc blkname acVer)<br />   (vl-load-com)<br />   (setq acad(vlax-get-acad-object)<br />         doc(vlax-get-property acad'activedocument)<br />         acVer(atoi(getvar "ACADVER"))<br />         *DBX(vla-GetInterfaceObject *ACAD(if(< acVer 16)"ObjectDBX.AxDbDocument"(strcat"ObjectDBX.AxDbDocument."(itoa acVer))))<br />         *Dbmdl(vla-get-ModelSpace *dbxobj)<br />         blk(vlax-invoke-method(vlax-get-property doc'blocks)'add(vlax-3d-point 0 0)"*U")<br />         blkname(vlax-get-property blk'name))<br />   (and(setq files(cadr(GETPATH"指定要合并的Excel文件夹""*.dwg")))<br />       (vl-some(function(lambda(x / lays la lay)<br />                          (vlax-for x blk(vlax-invoke-method x 'delete))<br />                          (and(not(VL-CATCH-ALL-ERROR-P(VL-CATCH-ALL-APPLY(function vlax-invoke-method)(List(*DBX"open"x)))))<br />                              (vlax-for x(vlax-get-property *DBX'layers)(setq lays(cons(list(vlax-get-property x 'name))lays)))<br />                              (vlax-for x *Dbmdl<br />                                (setq la(assoc(vlax-get-property x'layer)lays)lays(cons(vl-list*(car la)x(cdr la))(vl-remove la lays))))<br />                              (vl-some(function(lambda(a)<br />                                                 (and(cadr a)<br />                                                     (vlax-invoke-method doc'wblock(strcat(VL-FILENAME-DIRECTORY x)(VL-FILENAME-base x)(car a)".dwg")<br />                                                       (vlax-invoke-method *DBX'CopyObjects(l2array(cdr a))))<br />                                                     nil)))lays))))<br />               files))<br />   (vlax-invoke-method blk 'delete))

未来得及测试

shiyj

llsheng_73 发表于 2022-12-9 09:51
未来得及测试

不懂就问，第33行代码中有一句 (car la x) ，好像car参数只有一个：表，为甚能有两个参数？

llsheng_73

shiyj 发表于 2022-12-9 23:52
不懂就问，第33行代码中有一句 (car la x) ，好像car参数只有一个：表，为甚能有两个参数？

没注意到。写错了
已更正

shiyj

大佬，你的代码我使劲调试还是不能运行，提示：参数类型错误: VLA-OBJECT nil  能否抽个使劲帮忙试运行一次。