批量导出图纸中的块(批量wblock)
原文件来自网络上，相信很多人都见过、用过。原代码如下：; ----------------------------------------------------------------------
; (Wblocks all local block definitions to target path)
; Copyright (C) 2000 DotSoft, All Rights Reserved
; Website: http://www.dotsoft.com
; ----------------------------------------------------------------------
; DISCLAIMER:DotSoft Disclaims any and all liability for any damages
; arising out of the use or operation, or inability to use the software.
; FURTHERMORE, User agrees to hold DotSoft harmless from such claims.
; DotSoft makes no warranty, either expressed or implied, as to the
; fitness of this product for a particular purpose.All materials are
; to be considered 慳s-is? and use of this software should be
; considered as AT YOUR OWN RISK.
; ----------------------------------------------------------------------
(defun c:wblockm ()
(setq cmdecho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
;
(if (not dos_getdir)
(setq path (getstring "\nDS> Target Folder: " T))
(setq path (dos_getdir "Target Folder" (getvar "DWGPREFIX")))
)
(if (/= path nil)
(progn
(if (= (substr path (strlen path) 1) "\\")
(setq path (substr path 1 (1- (strlen path))))
)
(princ "\nDS> Building List of Blocks ... ")
(setq lst nil)
(setq itm (tblnext "BLOCK" T))
(while (/= itm nil)
(setq nam (cdr (assoc 2 itm)))
(setq pass T)
(if (/= (cdr (assoc 1 itm)) nil)
(setq pass nil)
(progn
(setq ctr 1)
(repeat (strlen nam)
(setq chk (substr nam ctr 1))
(if (or (= chk "*")(= chk "|"))
(setq pass nil)
)
(setq ctr (1+ ctr))
)
)
)
(if (= pass T)
(setq lst (cons nam lst))
)
(setq itm (tblnext "BLOCK"))
)
(setq lst (acad_strlsort lst))
(princ "Done.")
;
(foreach blk lst
(setq fn (strcat path (chr 92) blk))
(if (findfile (strcat fn ".dwg"))
(command "_.WBLOCK" fn "_Y" blk)
(command "_.WBLOCK" fn blk)
)
)
)
)
;
(setvar "CMDECHO" cmdecho)
(princ)
)
不过原文件有缺点，就是没有加载doslib就无法选定目录，而要手输，麻烦得很。
还有就是原版是英文版。
小可抽空汉化，修改优化了一下，分享给大家。
1、目录设定在文件同目录下，【文件名_导出图块】文件夹；
2、增加数量提示；3、滤除标注箭头块。
老规矩，愿意打赏的可以直接下载LSP文件。
; ----------------------------------------------------------------------
; (Wblocks all local block definitions to target path)
; Copyright (C) 2000 DotSoft, All Rights Reserved
; Website: http://www.dotsoft.com
; ----------------------------------------------------------------------
; DISCLAIMER: DotSoft Disclaims any and all liability for any damages
; arising out of the use or operation, or inability to use the software.
; FURTHERMORE, User agrees to hold DotSoft harmless from such claims.
; DotSoft makes no warranty, either expressed or implied, as to the
; fitness of this product for a particular purpose. All materials are
; to be considered 'as-is', and use of this software should be
; considered as AT YOUR OWN RISK.
; ----------------------------------------------------------------------
;;;2024-12-17
;;;Modified by 煮茗
(defun c:wblockm ()
(setq cmdecho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq lst nil)
(setq itm (tblnext "BLOCK" T))
(while (/= itm nil)
(setq nam (cdr (assoc 2 itm)))
(setq pass T)
(if (/= (cdr (assoc 1 itm)) nil)
(setq pass nil)
(progn
(setq ctr 1)
(repeat (strlen nam)
(setq chk (substr nam ctr 1))
(if (or (= chk "*")(= chk "|"))
(setq pass nil)
)
(setq ctr (1+ ctr))
)
)
)
(if (= pass T)
(setq lst (cons nam lst))
)
(setq itm (tblnext "BLOCK"))
)
(setq lst (acad_strlsort lst));排序
(setq bnum (length lst))
(princ (strcat "\n本图共有" (vl-princ-to-string bnum) "个块图元。"))
(setq BVL (getstring "\n是否导出这些图块（y/n）?【注意：标注箭头的图块将不导出。】<N>"))
(if (or (= BVL "Y")(= BVL "y"))
(progn
(setq path0 (GetVar "DwgPrefix"))
(setq Dir0 (vl-string-subst "_导出图块" ".dwg" (GetVar "DwgName")))
(setq path (strcat path0 Dir0))
(if (not (VL-FILE-DIRECTORY-P path))
(vl-mkdir path)
)
(if (= (substr path (strlen path) 1) "\\")
(setq path (substr path 1 (1- (strlen path))))
)
(princ "\n请稍等，正在导出图块... \n")
(setq i 0)
(foreach blk lst
(if (and (/= blk "_ArchTick")(/= blk "_BoxBlank")(/= blk "_BoxFilled")(/= blk "_Closed")(/= blk "_ClosedBlank")(/= blk "_DatumBlank")(/= blk "_DatumFilled")(/= blk "_Dot")(/= blk "_DotBlank")(/= blk "_DotSmall")(/= blk "_Integral")(/= blk "_Oblique")(/= blk "_Open")(/= blk "_Open30")(/= blk "_Open90")(/= blk "_Origin")(/= blk "_Origin2")(/= blk "_Small"))
(progn
(setq fn (strcat path (chr 92) blk))
(if (findfile (strcat fn ".dwg"))
(command "_.WBLOCK" fn "_Y" blk)
(command "_.WBLOCK" fn blk)
)
(setq i (+ i 1))
)
)
)
(princ (strcat "\n操作完成。已导出" (vl-princ-to-string i) "个块图元。"))
(startapp "explorer" path)
)
)
(setvar "CMDECHO" cmdecho)
(princ)
)
lengxiaxi 发表于 2024-12-19 08:23
2016/2020/2025；均加载失败；
(if (= (substr path (strlen path) 1) "\")
"\"改成"\\"
系统会“吃掉”一个\ 1836794553@qq.c 发表于 2024-12-19 13:46
这个可以批量导出到一个DWG文件里面吗
可以是可以，不过要放到一个文件里，那就要把这些块排列整齐。
暂时没空加这个功能。:P- szhorse 发表于 2024-12-18 22:18
感谢大佬从1970年穿越过来分享源码
哈哈，我也不晓得为啥系统显示这样。 谢谢分享 感谢大神分享 感谢大神分享 感谢大神分享 感谢大佬从1970年穿越过来分享源码 谢谢分享。。。 2016/2020/2025；均加载失败；
:o- 感感谢分享，试用一下
页:
[1]
2