求编程：多个cad图内有多个图层，现在想要批量将所有文件按图层写出
求编程：有一批cad图，内有多个图层，现在想要批量处理，将所有文件按图层写到新的文件，命名规则如：原CAD文件名+图层名.dwg。然后贴上我在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(strcatdwgname-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-putFOLDER
"Attributes"
1 ;此处如果改成2.则创建隐藏文件夹
)
(vlax-release-object FOLDER)
(vlax-release-object SYS)
)
;;; (alert (strcat "\"" FNAME "\" 档案夹已存在!!"))
)
(princ)
) 转发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 于 2022-12-8 22:39 编辑
(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 (assoc2lnm)))"" "0,0" ss "" "oops")
)
)
(setvar "CMDECHO" 1)
(princ)
) 本帖最后由 shiyj 于 2022-12-8 22:47 编辑
yanshengjiang 发表于 2022-12-8 16:16
转发z版的一个源码
(vl-load-com)
感谢回复。之前借鉴Z版代码了，程序不能批处理一个文件夹，还需要用批处理工具，再一个需要打开文件才能处理，速度不是很快。 本帖最后由 llsheng_73 于 2022-12-10 13:45 编辑
(defun GetFolder(msg / WinShell shFolder path catchit);选取文件夹
(setq shFolder(vlax-invoke-method (vlax-create-object "Shell.Application")'BrowseForFolder 0 msg 1))
(setqcatchit(vl-catch-all-apply'(lambda()(setq shFolder(vlax-get-property shFolder'self))
(setq path(vlax-get-property shFolder'path)))))
(if(vl-catch-all-error-p catchit)nil path))
(defun xdirectory(folder)
(setq folder(list(list folder)))
(while(car(setq folder(cons(apply'append(mapcar'(lambda(x)(mapcar'(lambda(y)(strcat x"\\"y))(cddr(vl-directory-files X nil -1))))
(car folder)))folder))))(apply'append folder))
(defun getpath(msg ext / path paths files)
(and(setq path(GETFOLDER msg))
(setq paths(XDIRECTORY path))
(setq files(apply'append(mapcar'(lambda(x)(mapcar'(lambda(y)(strcat x "\\"y))(VL-DIRECTORY-FILES x ext 1)))paths)))
)(list paths files))
(defun l2array(l / A)
(vlax-safearray-fill(vlax-make-safearray 9(cons 0(1-(length l))))
(mapcar(function(lambda(x / a)(setq a(type x))(cond((='ename a)(vlax-ename->vla-object x))((='VLA-OBJECT a)x))))l)))
(defun c:tt(/ files acad layers *DBX *Dbmdl blk doc blkname acVer)
(vl-load-com)
(setq acad(vlax-get-acad-object)
doc(vlax-get-property acad'activedocument)
acVer(atoi(getvar "ACADVER"))
*DBX(vla-GetInterfaceObject *ACAD(if(< acVer 16)"ObjectDBX.AxDbDocument"(strcat"ObjectDBX.AxDbDocument."(itoa acVer))))
*Dbmdl(vla-get-ModelSpace *dbxobj)
blk(vlax-invoke-method(vlax-get-property doc'blocks)'add(vlax-3d-point 0 0)"*U")
blkname(vlax-get-property blk'name))
(and(setq files(cadr(GETPATH"指定要合并的Excel文件夹""*.dwg")))
(vl-some(function(lambda(x / lays la lay)
(vlax-for x blk(vlax-invoke-method x 'delete))
(and(not(VL-CATCH-ALL-ERROR-P(VL-CATCH-ALL-APPLY(function vlax-invoke-method)(List(*DBX"open"x)))))
(vlax-for x(vlax-get-property *DBX'layers)(setq lays(cons(list(vlax-get-property x 'name))lays)))
(vlax-for x *Dbmdl
(setq la(assoc(vlax-get-property x'layer)lays)lays(cons(vl-list*(car la)x(cdr la))(vl-remove la lays))))
(vl-some(function(lambda(a)
(and(cadr a)
(vlax-invoke-method doc'wblock(strcat(VL-FILENAME-DIRECTORY x)(VL-FILENAME-base x)(car a)".dwg")
(vlax-invoke-method *DBX'CopyObjects(l2array(cdr a))))
nil)))lays))))
files))
(vlax-invoke-method blk 'delete))
未来得及测试
llsheng_73 发表于 2022-12-9 09:51
未来得及测试
不懂就问，第33行代码中有一句 (car la x) ，好像car参数只有一个：表，为甚能有两个参数？ 本帖最后由 llsheng_73 于 2022-12-10 13:46 编辑
shiyj 发表于 2022-12-9 23:52
不懂就问，第33行代码中有一句 (car la x) ，好像car参数只有一个：表，为甚能有两个参数？
没注意到。写错了:L
已更正
本帖最后由 shiyj 于 2022-12-11 12:38 编辑
大佬，你的代码我使劲调试还是不能运行，提示：参数类型错误: VLA-OBJECT nil能否抽个使劲帮忙试运行一次。
页:
[1]