求批量写块，

ly8zx2109

求批量写块（WBLOCK），CAD图中块名不同，但是有有一定规律，  可编缉 写出文件名，求各位高手给个程序。谢谢。

Gu_xl

1. (defun c:tt (/ *error* cmdecho filename name path i)
   
2.   (defun *error* (s)
   
3.     (princ s)
   
4.     (setvar 'cmdecho cmdecho)
   
5.     )
   
6.   (setq cmdecho (getvar 'cmdecho))
   
7.   (setvar 'cmdecho 0)
   
8.   (cond
   
9.     ((not (setq filename (getfiled "保存文件名" "" "dwg" 1))))
   
10.     (t
    
11.      (setq name (VL-FILENAME-BASE filename)
    
12.            path (strcat (VL-STRING-RIGHT-TRIM
    
13.                           "\\"
    
14.                           (VL-FILENAME-DIRECTORY filename)
    
15.                           )
    
16.                         "\\"
    
17.                         )
    
18.            i    0
    
19.            )
    
20.      (princ "\n选择写块物体:")
    
21.      (while (setq ss (ssget))
    
22.        (command "wblock"
    
23.                 (strcat path name (itoa (setq i (1+ i))) ".dwg")
    
24.                 ""
    
25.                 "0,0,0"
    
26.                 ss
    
27.                 ""
    
28.                 )
    
29.        (command "oops")
    
30.        (princ "\n继续选择写块物体<右键结束>:")
    
31.        )
    
32.      )
    
33.     )
    
34.   (setvar 'cmdecho cmdecho)
    
35.   (princ)
    
36.   )

(defun c:tt (/ *error* cmdecho filename name path i)<br />   (defun *error* (s)<br />     (princ s)<br />     (setvar 'cmdecho cmdecho)<br />     )<br />   (setq cmdecho (getvar 'cmdecho))<br />   (setvar 'cmdecho 0)<br />   (cond<br />     ((not (setq filename (getfiled "保存文件名" "" "dwg" 1))))<br />     (t<br />      (setq name (VL-FILENAME-BASE filename)<br />            path (strcat (VL-STRING-RIGHT-TRIM<br />                           "\\"<br />                           (VL-FILENAME-DIRECTORY filename)<br />                           )<br />                         "\\"<br />                         )<br />            i    0<br />            )<br />      (princ "\n选择写块物体:")<br />      (while (setq ss (ssget))<br />        (command "wblock"<br />                 (strcat path name (itoa (setq i (1+ i))) ".dwg")<br />                 ""<br />                 "0,0,0"<br />                 ss<br />                 ""<br />                 )<br />        (command "oops")<br />        (princ "\n继续选择写块物体<右键结束>:")<br />        )<br />      )<br />     )<br />   (setvar 'cmdecho cmdecho)<br />   (princ)<br />   )

zyhandw

有一定规律，是什么规律？还是上传测试用的附件再说吧

Gu_xl

1. ;c:blk 批量块输出到指定文件夹文件 By Gu_xl
   
2. (defun c:blk (/ WINSHELL SHFOLDER CATCHIT PATH BLL XL K KN BL N B expert cmdecho)
   
3.   (setq expert (getvar 'expert)
   
4.         cmdecho (getvar 'cmdecho)
   
5.         )
   
6.   (setvar 'expert 5)
   
7.   (setvar 'cmdecho 0)
   
8.     (setq winshell (vlax-create-object "Shell.Application"))
   
9.   (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 "选择文件夹" 1))
   
10.   (setq
    
11.     catchit (vl-catch-all-apply
    
12.               '(lambda ()
    
13.                  (setq shFolder (vlax-get-property shFolder 'self))
    
14.                  (setq path (vlax-get-property shFolder 'path))
    
15.                )
    
16.             )
    
17.   )
    
18.   (if (not (vl-catch-all-error-p catchit))
    
19.    (progn
    
20.   (setq blL '() xl '(0 0) k 0 kn 0)
    
21.   (setq bl (tblnext "BLOCK" T))
    
22.   (setq bll (cons (cdr (assoc 2 bl)) blL))
    
23.   (while (setq bl (tblnext "block"))
    
24.          (setq bll (cons (cdr (assoc 2 bl)) blL))
    
25.      )
    
26. 
    
27.   (setq bll (acad_strLSort bll))
    
28.   (foreach b bll
    
29.     (command "wblock" (strcat path "\\" b) b)
    
30.     )
    
31.   )
    
32.     )
    
33.   (vlax-release-object winshell)
    
34.   (setvar 'expert expert)
    
35.   (setvar 'cmdecho cmdecho)
    
36.   (princ)
    
37. )

;c:blk 批量块输出到指定文件夹文件 By Gu_xl<br /> (defun c:blk (/ WINSHELL SHFOLDER CATCHIT PATH BLL XL K KN BL N B expert cmdecho)<br />   (setq expert (getvar 'expert)<br />         cmdecho (getvar 'cmdecho)<br />         )<br />   (setvar 'expert 5)<br />   (setvar 'cmdecho 0)<br />     (setq winshell (vlax-create-object "Shell.Application"))<br />   (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 "选择文件夹" 1))<br />   (setq<br />     catchit (vl-catch-all-apply<br />               '(lambda ()<br />                  (setq shFolder (vlax-get-property shFolder 'self))<br />                  (setq path (vlax-get-property shFolder 'path))<br />                )<br />             )<br />   )<br />   (if (not (vl-catch-all-error-p catchit))<br />    (progn<br />   (setq blL '() xl '(0 0) k 0 kn 0)<br />   (setq bl (tblnext "BLOCK" T))<br />   (setq bll (cons (cdr (assoc 2 bl)) blL))<br />   (while (setq bl (tblnext "block"))<br />          (setq bll (cons (cdr (assoc 2 bl)) blL))<br />      )<br /> <br />   (setq bll (acad_strLSort bll))<br />   (foreach b bll<br />     (command "wblock" (strcat path "\\" b) b)<br />     )<br />   )<br />     )<br />   (vlax-release-object winshell)<br />   (setvar 'expert expert)<br />   (setvar 'cmdecho cmdecho)<br />   (princ)<br /> )

zyhandw

向G版学习了

ly8zx2109

就是把附件中的图分为四张图。不是把每个块分出去。谢谢版主。

ly8zx2109

就是这个附件

ly8zx2109

谢谢

ly8zx2109

AutoCAD Batchplot 批量打印程序 这个程序就可做到这些功能，后来才发现的，谢谢版主了。

幸福是真

Gu_xl 发表于 2013-4-16 09:15

块多了会导至CAD卡死