[编程申请]：谁能编个这样的批量程序?

lewis240

谁能编个批量的先炸开后转成DXF(R14)的程序?是针对放在同个目录下的DWG
先炸是为了炸开文件里的块或圆弧(最好是能把圆弧炸成直线的)
转DXF是为了转的其它软件
以前也找过类似的批量工具但都只有转DXF的功能没有先炸一下的功能
谢谢!!!

zxq0220

将下面的代码拷贝粘贴到记事本中，以ACAD.LSP为名另存在默认路径下。
启动ACAD后即可连续运行。运行时自动删除指定目录下的旧文件，因此要备份原文件。
程序直到目录中无文件出错停止。运行时如果文件太多，系统资源会耗尽，需要重新启动系统。
当工作完后，将ACAD.LSP改名即可正常执行ACAD。程序可以在R14下运行。
(DEFUN S::STARTUP ()
(SETQ PATH "F:\\WORKINGDIR\\") ;路径可以替换
(COMMAND "SHELL" (STRCAT "DIR " PATH "*.DWG /B >DWG.TXT"))
(SETQ F (OPEN "DWG.TXT" "r"))
(SETQ NMM (READ-LINE F))
(WHILE (NOT (SETQ F1 (OPEN (STRCAT PATH NMM) "r")))
  (SETQ NMM (READ-LINE F))
)
(CLOSE F) (CLOSE F1)
(IF (> (STRLEN NMM) 0) (PROGN
  (COMMAND "OPEN" (STRCAT PATH NMM))
  (COMMAND "ZOOM" "E")
  (SETQ SA (SSGET "X" (LIST (CONS 0 "INSERT"))))
  (IF (/= SA nil) (PROGN
   (SETQ I 0 SL (SSLENGTH SA))
   (REPEAT SA
    (SETQ SN1 (SSNAME SA I) I (1+ I))
    (COMMAND "EXPLODE" SN1)
   )
  ))
  (COMMAND "SHELL" (STRCAT "ERASE " PATH NMM))
  (SETQ NMM (SUBSTR NMM 1 (- (STRLEN NMM) 4)))
  (COMMAND "DXFOUT" "R14" (STRCAT PATH NMM) "NEW" "Y" "")
))
(PRINC)
)

lewis240

小弟！愚昧！看的不是很明白！！不好意思！默然指的是什么？
程序中的(SETQ PATH "F:\\WORKINGDIR\\") ;路径可以替换
的;路径可以替换是否可以删掉？
是否是把F:\\WORKINGDIR改成图纸文件放的位置？
请赐教！谢谢！！

zxq0220

程序重新写过。
将下面的代码拷贝粘贴到记事本中，以MADEDXF.LSP为名保存在ACAD默认搜索路径下。
进入ACAD后，用命令(LOAD"MADEDXF")或APPLOAD加载。
键入MADEDXF开始执行。
运行时如果文件太多，系统资源或硬盘空间会耗尽，需要重新启动系统或整理硬盘。
程序可以在R14下运行。
[php]
(DEFUN C:MADEDXF ()
(SETVAR "CMDECHO" 0)
(SETVAR "CMDDIA" 0)
(SETQ PATH "F:\\WORKINGDIR\\") ;路径可以替换
(WHILE (NOT (SETQ F (OPEN "DWG.TXT" "r")))
(COMMAND "SHELL" (STRCAT "DIR " PATH "*.DWG /B >DWG.TXT"))
)
(WHILE (SETQ NMM (READ-LINE F))
(COMMAND "_INSERT" (STRCAT PATH NMM) "0,0" "1" "")
(COMMAND "ZOOM" "E" "REGEN")
(SETQ P1 (GETVAR "EXTMIN") P2 (GETVAR "EXTMAX"))
(SETQ SA (SSGET "X" (LIST (CONS 0 "INSERT"))))
(IF (/= SA nil) (PROGN
  (SETQ I 0 SL (SSLENGTH SA))
  (REPEAT SL
   (SETQ SN1 (SSNAME SA I) I (1+ I))
   (COMMAND "EXPLODE" SN1)
  )
))
(SETQ NMM (SUBSTR NMM 1 (- (STRLEN NMM) 4)))
(COMMAND "DXFOUT" (STRCAT PATH NMM) "O" P1 P2 "" "")
(COMMAND "ERASE" "C" P1 P2 "")
)
(CLOSE F)
(SETVAR "CMDDIA" 1)
(SETVAR "CMDECHO" 1)
(PRINC)
)
[/php]
回复lewis240：
1、分号后的“路径可以替换”是程序注解，删不删都行。
2、WORKINGDIR就是指您图纸文件的位置。

lewis240

不好意思！！大侠还是不行！键入后：
未知命令“MADEDXF”。按 F1 查看帮助

silen618

将
(SETQ PATH "F:\WORKINGDIR\") ;路径可以替换
改为
(SETQ PATH "F:\\WORKINGDIR\\") ;路径可以替换
但真不知乍用。

lewis240

恩！！楼上是对的
照着改了能键入这命令了
可是大侠还是不能用：...
命令:MASEDXF
需要有效的数值角度或第二点.
错误:函数被取消
指定旋转角度<0>:

zxq0220

程序已更改。使用时要在空白的新图中执行程序。
[php]
(DEFUN C:MADEDXF ()
(SETVAR "CMDECHO" 0)
(SETVAR "CMDDIA" 0)
(COMMAND "UNDO" "C" "N"
(SETQ PATH "F:\\WORKINGDIR\\") ;路径可以替换
(WHILE (NOT (SETQ F (OPEN "DWG.TXT" "r")))
  (COMMAND "SHELL" (STRCAT "DIR " PATH "*.DWG /B >DWG.TXT"))
)
(WHILE (SETQ NMM (READ-LINE F))
  (COMMAND "_INSERT" (STRCAT "*" PATH NMM) "0,0" "1" "")
  (COMMAND "ZOOM" "E" "REGEN")
  (SETQ P1 (GETVAR "EXTMIN") P2 (GETVAR "EXTMAX"))
  (SETQ SA (SSGET "X" (LIST (CONS 0 "INSERT"))))
  (IF (/= SA nil) (PROGN
    (SETQ I 0 SL (SSLENGTH SA))
    (REPEAT SL
     (SETQ SN1 (SSNAME SA I) I (1+ I))
     (COMMAND "EXPLODE" SN1)
    )
  ))
  (SETQ NMM (SUBSTR NMM 1 (- (STRLEN NMM) 4)))
  (COMMAND "DXFOUT" (STRCAT PATH NMM) "O" P1 P2 "" "")
  (COMMAND "ERASE" "C" P1 P2 "" "LIMITS" "" "200,120" "ZOOM" "A" "REGEN")
)
(CLOSE F)
(COMMAND "UNDO" "A")
(SETVAR "CMDDIA" 1)
(SETVAR "CMDECHO" 1)
(PRINC)
)
[/php]

lewis240

命令: _appload 已成功加载 MADEDXF.LSP
命令:
错误: 输入的列表有缺陷
:
命令: MADEDXF
未知命令“MADEDXF”。按 F1 查看帮助。
大哥！还不行
再加点油啊！

silen618

再试一下这个……

(defun c:madedxf ()
  (setvar "cmdecho" 0)
  (setvar "cmddia" 0)
  (setq path "d:/101/")  
  (setq link (vl-directory-files path "*.dwg" 1))
  (setq long (1- (length link)))
  (foreach nam link
    (command "._undo" "be")
    (princ (strcat "\n正在处理文件" nam))
    (princ "\n请等待.......")   
    (command "_insert" (strcat "*" path nam) "0,0" "1" "")
    (command "zoom" "e" "regen")
    (setq p1 (getvar "extmin")
          p2 (getvar "extmax")
          )
    (setq sa (ssget "x"))
    (setq nam (substr nam 1 (- (strlen nam) 4)))
    (command "dxfout" (strcat path nam) "o" sa "" "")
    (if        (> long 0)
      (progn
        (princ "\n处理完毕!  还有 ")
        (princ long)
        (princ " 个文件需要处理。")
        (setq long (1- long))
        )
      (princ "\n全部文件处理完毕 !!!")
      )
    (command "._undo" "e")
    (command "._u")
    )
  (setvar "cmddia" 1)
  (setvar "cmdecho" 1)
  (princ)
  )

lewis240

楼上的大哥！你的程序可以把DWG转成DXF，但是他们并没有炸过！
请改进一下吧！

xyp1964

未经同意修改：
[php]
(defun c:madedxf ()
  (setvar "cmdecho" 0)
  (setvar "cmddia" 0)
  (setq        dwgname
         (getfiled "请点取该目录要转DXF的任意一个文件:" "" "dwg" 16)
  )
  (setq path (strcat (vl-filename-directory dwgname) "\\"))
  (setq link (vl-directory-files path "*.dwg" 1))
  (setq long (1- (length link)))
  (foreach nam link
    (command "._undo" "be")
    ;;(princ (strcat "\n正在处理文件" nam))
    ;;(princ "\n请等待.......")
    (command "_insert" (strcat "*" path nam) "0,0" "1" "")
    (command "zoom" "e" "regen")
    (setq p1 (getvar "extmin")
          p2 (getvar "extmax")
    )
    (repeat 2
      (setq sa (ssget "w" p1 p2))
      (vl-cmdf "explode" sa "")
    )
    ;;(setq sa (ssget "x"))
    (setq nam (substr nam 1 (- (strlen nam) 4)))
    (command "dxfout" (strcat path nam) "o" sa "" "")
    ;|(if        (> long 0)
      (progn
        (princ "\n处理完毕! 还有 ")
        (princ long)
        (princ " 个文件需要处理。")
        (setq long (1- long))
      )
      (princ "\n全部文件处理完毕 !!!")
    )
    |;
    (command "._undo" "e")
    (command "._u")
  )
  (setvar "cmddia" 1)
  (setvar "cmdecho" 1)
  (princ)
)
[/php]

zxq0220

最初由 lewis240 发布
[B]命令: _appload 已成功加载 MADEDXF.LSP
命令:
错误: 输入的列表有缺陷
:
命令: MADEDXF
未知命令“MADEDXF”。按 F1 查看帮助。
大哥！还不行
再加点油啊！ [/B]

第四行少了一个括弧。程序更新如下：

2. 
   
3. (DEFUN C:MADEDXF ()
   
4. (SETVAR "CMDECHO" 0)
   
5. (SETVAR "CMDDIA" 0)
   
6. (COMMAND "UNDO" "C" "N")
   
7. (SETQ PATH "F:\\WORKINGDIR\") ;路径可以替换;
   
8. (WHILE (NOT (SETQ F (OPEN "DWG.TXT" "r")))
   
9.   (COMMAND "SHELL" (STRCAT "DIR " PATH "*.DWG /B >DWG.TXT"))
   
10. )
    
11. (WHILE (SETQ NMM (READ-LINE F))
    
12.   (COMMAND "_INSERT" (STRCAT "*" PATH NMM) "0,0" "1" "")
    
13.   (COMMAND "ZOOM" "E" "REGEN")
    
14.   (SETQ P1 (GETVAR "EXTMIN") P2 (GETVAR "EXTMAX"))
    
15.   (SETQ SA (SSGET "X" (LIST (CONS 0 "INSERT"))))
    
16.   (IF (/= SA nil) (PROGN
    
17.     (SETQ I 0 SL (SSLENGTH SA))
    
18.     (REPEAT SL
    
19.      (SETQ SN1 (SSNAME SA I) I (1+ I))
    
20.      (COMMAND "EXPLODE" SN1)
    
21.     )
    
22.   ))
    
23.   (SETQ NMM (SUBSTR NMM 1 (- (STRLEN NMM) 4)))
    
24.   (COMMAND "DXFOUT" (STRCAT PATH NMM) "O" P1 P2 "" "")
    
25.   (COMMAND "ERASE" "C" P1 P2 "" "LIMITS" "" "200,120" "ZOOM" "A" "REGEN")
    
26. )
    
27. (CLOSE F)
    
28. (COMMAND "UNDO" "A")
    
29. (SETVAR "CMDDIA" 1)
    
30. (SETVAR "CMDECHO" 1)
    
31. (PRINC)
    
32. )
    

<br /> (DEFUN C:MADEDXF ()<br /> (SETVAR "CMDECHO" 0)<br /> (SETVAR "CMDDIA" 0)<br /> (COMMAND "UNDO" "C" "N")<br /> (SETQ PATH "F:\\WORKINGDIR\") ;路径可以替换;<br /> (WHILE (NOT (SETQ F (OPEN "DWG.TXT" "r")))<br />   (COMMAND "SHELL" (STRCAT "DIR " PATH "*.DWG /B >DWG.TXT"))<br /> )<br /> (WHILE (SETQ NMM (READ-LINE F))<br />   (COMMAND "_INSERT" (STRCAT "*" PATH NMM) "0,0" "1" "")<br />   (COMMAND "ZOOM" "E" "REGEN")<br />   (SETQ P1 (GETVAR "EXTMIN") P2 (GETVAR "EXTMAX"))<br />   (SETQ SA (SSGET "X" (LIST (CONS 0 "INSERT"))))<br />   (IF (/= SA nil) (PROGN<br />     (SETQ I 0 SL (SSLENGTH SA))<br />     (REPEAT SL<br />      (SETQ SN1 (SSNAME SA I) I (1+ I))<br />      (COMMAND "EXPLODE" SN1)<br />     )<br />   ))<br />   (SETQ NMM (SUBSTR NMM 1 (- (STRLEN NMM) 4)))<br />   (COMMAND "DXFOUT" (STRCAT PATH NMM) "O" P1 P2 "" "")<br />   (COMMAND "ERASE" "C" P1 P2 "" "LIMITS" "" "200,120" "ZOOM" "A" "REGEN")<br /> )<br /> (CLOSE F)<br /> (COMMAND "UNDO" "A")<br /> (SETVAR "CMDDIA" 1)<br /> (SETVAR "CMDECHO" 1)<br /> (PRINC)<br /> )<br />

lewis240

xyp1964 大哥怎么用？？？路径写在那？？？和上面程序的不一样不太明白！！？
zxq0220  大哥这次好点了，文件夹里有转成DXF了，可是只有一个转成的其他两个不行好象一个复杂点的原因？一个是因为有弧？（我不不太明白）而且没有DXF炸过！？
希望再接再厉加油啊好人！！

xyp1964

最初由 lewis240 发布
[B]xyp1964 大哥怎么用？？？路径写在那？？？和上面程序的不一样不太明白！！？
zxq0220  大哥这次好点了，文件夹里有转成DXF了，可是只有一个转成的其他两个不行好象一个复杂点的原因？一个是因为有弧？（我不不太明... [/B]

这是一个“傻瓜”程序，不用设路径！用一下就知道了！