明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: iceberg2509

[资源] 无聊发布CAD版本转换以及去除教育版戳记程序源代码

    [复制链接]
发表于 2012-10-16 23:23:22 | 显示全部楼层
呵呵这样省事多了
发表于 2012-10-17 00:11:05 | 显示全部楼层
谢谢lz奉献
发表于 2012-11-20 09:28:39 | 显示全部楼层
只能运行在2010以上的版本
发表于 2012-12-9 18:36:52 | 显示全部楼层
  1. ;;DWG文件版本批量转换程序 命令 DwgConverter
  2. ;;DWG文件去除教育版标记   命令 DelEduLog
  3. ;;程序源码来自明经CAD iceberg2509 于2011.10.18
  4. ;;xiaoyingzi修改成支持autocad2004~2010
  5. ;;=================DWG文件版本批量转换程序=====================
  6. (defun C:Dwgbbzh (/     pass         DwgVer     DwgType
  7.            dcl_id     pop_ver     OldError     FileExt
  8.            IsDxfExt     Initdir     HOLDLSP     AcadApp
  9.            DocObj     Index       DwgName     BaseName
  10.            filepath     DxfFile     NewFile     dwgfileLst
  11.            lst_DwgFile tog_subfolder
  12.           )
  13.           ;|
  14. object.SaveAsType
  15.   object  PreferencesOpenSave
  16.   The object this property applies to.
  17.   SaveAsType
  18.   acSaveAsType enum; read-write
  19.   acR14_dwg     AutoCAD R14 DWG (*.dwg)
  20.   ac2000_dwg     AutoCAD 2000 DWG (*.dwg)
  21.   ac2000_dxf    AutoCAD 2000 DXF (*.dxf)
  22.   ac2000_Template    AutoCAD 2000 Drawing Template File (*.dwt)
  23.   ac2004_dwg     AutoCAD 2004 DWG (*.dwg)
  24.   ac2004_dxf     AutoCAD 2004 DXF (*.dxf)
  25.   ac2004_Template   AutoCAD 2004 Drawing Template File (*.dwt)
  26.   ac2007_dwg    AutoCAD 2007 DWG (*.dwg)
  27.   ac2007_dxf     AutoCAD 2007 DXF (*.dxf)
  28.   ac2007_Template   AutoCAD 2007 Drawing Template File (*.dwt)
  29.   ac2010_dwg      AutoCAD 2010 DWG (*.dwg)
  30.   ac2010_dxf       AutoCAD 2010 DXF (*.dxf)
  31.   ac2010_Template    AutoCAD 2010 Drawing Template File (*.dwt)
  32.   acNative     A synonym for the current drawing release format. If you want your application to save the drawing in the format of whatever version of AutoCAD the application is running on, then use the acNative format.
  33.   AcUnknown    Read-only. The drawing type is unknown or invalid.
  34. Remarks
  35. The initial value for this property is ac2010_dwg. The following values are obsolete: acR13_DWG, acR13_DXF, acR14_DWG, and acR14_DXF.
  36. |;
  37.   ;;Sub DxfOut(ByVal FileName As String, Optional ByVal precision As Variant, Optional ByVal SaveThumbnailImage As Variant)
  38.   ;;Sub SaveAs(ByVal FileName As String, Optional ByVal vSecurityParams As Variant)
  39.   ;;Sub Open  (ByVal FileName As String, Optional ByVal Password As Variant)
  40.   ;;============加载dwg文件到列表==============
  41.   (defun LoadDwgFileLst  (fileslst / HasOpenFiles)
  42.     (if  fileslst
  43.       (progn
  44.   (if dwgfileLst
  45.     (progn
  46.       (mapcar '(lambda (tmpfile)
  47.            (setq dwgfileLst
  48.             (vl-remove (strcase tmpfile T) dwgfileLst)
  49.            )
  50.          )
  51.         fileslst
  52.       )
  53.       (setq dwgfileLst (append dwgfileLst fileslst))
  54.     )
  55.     (setq dwgfileLst fileslst)
  56.   )        ;end if
  57.   ;;检测文件是否打开
  58.   (setq HasOpenFiles (vl-remove-if 'VL-FILE-SYSTIME dwgfileLst)
  59.         dwgfileLst   (vl-remove-if-not 'VL-FILE-SYSTIME dwgfileLst)
  60.   )
  61.   (if dwgfileLst
  62.     (setq dwgfileLst (vl-sort dwgfileLst '<))
  63.   )
  64.   (if HasOpenFiles
  65.     (alert (strcat "以下文件已经被打开,无法添加到列表:\n"
  66.        (AddSeprate HasOpenFiles "\n")
  67.      )
  68.     )
  69.   )
  70.   (start_list "lst_DwgFile")
  71.   (mapcar 'add_list dwgfileLst)
  72.   (end_list)
  73.       )
  74.     )          ;end if
  75.     (OkBtnIsEnabled)
  76.   )          ;end defun

  77.   ;;============获取指定文件夹下的所有dwg文件=================
  78.   (defun AddDwgFilesInFolder (/ filter dwgPath dwgfiles)
  79.     (setq filter  "*.dwg"
  80.     dwgPath (GetFolderNew Initdir "选择DWG文件夹")
  81.     )
  82.     (if  dwgPath
  83.       (progn
  84.   (setq Initdir dwgPath)
  85.   (if (= "0" tog_subfolder)
  86.     (setq dwgfiles (GetAllSpecFilesInFolder dwgPath filter))
  87.     (setq dwgfiles (GetAllSpecFilesInFolders dwgPath filter))
  88.   )
  89.   (LoadDwgFileLst dwgfiles)
  90.       )
  91.     )
  92.   )          ;end defun

  93.   ;;===============获取选中的dwg文件=====================
  94.   (defun AddDwgFiles (/ flags diatl filter dwgfiles)
  95.     (setq flags   (+ 4 512 4096 32768 524288 1048576)
  96.     diatl   "选择文件"
  97.     filter "图形(*.dwg)|*.dwg"
  98.     )
  99.     (setq dwgfiles (GetMultiFiles flags diatl filter Initdir))
  100.     (if  dwgfiles
  101.       (progn
  102.   (setq Initdir (vl-filename-directory (car dwgfiles)))
  103.   (LoadDwgFileLst dwgfiles)
  104.       )
  105.     )
  106.   )          ;end defun

  107.   ;;=============移除按钮状态函数=======================
  108.   (defun DelBtnIsEnabled ()
  109.     (if  lst_DwgFile
  110.       (mode_tile "but_del" 0)
  111.       (mode_tile "but_del" 1)
  112.     )
  113.   )          ;end defun

  114.   ;;=============确认按钮是否激活函数=======================
  115.   (defun OkBtnIsEnabled  ()
  116.     (if  (null dwgfileLst)
  117.       (mode_tile "but_OK" 1)
  118.       (mode_tile "but_OK" 0)
  119.     )
  120.   )

  121.   ;;==============移除选定文件函数=======================
  122.   (defun RemoveDwgFiles  (/ IndexLst RemoveDwgLst)
  123.     (if  lst_DwgFile
  124.       (progn
  125.   (setq IndexLst     (makelist lst_DwgFile " ")
  126.         RemoveDwgLst (mapcar '(lambda (index)
  127.               (nth (atoi index) dwgfileLst)
  128.             )
  129.            IndexLst
  130.          )
  131.   )
  132.   ;;移除选定文件
  133.   (mapcar  '(lambda (tmpfile)
  134.        (setq dwgfileLst
  135.         (vl-remove (strcase tmpfile T) dwgfileLst)
  136.        )
  137.      )
  138.     RemoveDwgLst
  139.   )
  140.   (start_list "lst_DwgFile")
  141.   (mapcar 'add_list dwgfileLst)
  142.   (end_list)
  143.   (setq lst_DwgFile nil)
  144.       )
  145.     )          ;end if
  146.     (DelBtnIsEnabled)
  147.     (OkBtnIsEnabled)
  148.   )          ;end defun

  149.   ;;====================对话框驱动函数==========================
  150.   (defun ConvDwgLst ( / fname fn dclid lin return# )
  151.       (setq fname (vl-filename-mktemp nil nil ".dcl"))
  152.   (setq fn (open fname "w"))
  153. (write-line "" fn)
  154. (write-line "dcl_settings : default_dcl_settings { audit_level = 3; }" fn)
  155. (write-line "" fn)
  156. (write-line "" fn)
  157. (write-line "BatConVer : dialog {" fn)
  158. (write-line "    label = \"批量转换DWG文件版本\";" fn)
  159. (write-line "    : row {" fn)
  160. (write-line "        : column {" fn)
  161. (write-line "           : boxed_row {" fn)
  162. (write-line "               label = \"转换版本\";" fn)
  163. (write-line "               : popup_list {" fn)
  164. (write-line "                  key = \"pop_ver\";" fn)
  165. (write-line "                  //width=36;" fn)
  166. (write-line "               }" fn)
  167. (write-line "           }" fn)
  168. (write-line "           : boxed_row {" fn)
  169. (write-line "              label=\"DWG文件列表\";" fn)
  170. (write-line "              : list_box {                 " fn)
  171. (write-line "                 key=\"lst_DwgFile\";" fn)
  172. (write-line "                 width=70;" fn)
  173. (write-line "                 height=35;" fn)
  174. (write-line "                 allow_accept=true;" fn)
  175. (write-line "                multiple_select=true;" fn)
  176. (write-line "              }" fn)
  177. (write-line "          }" fn)
  178. (write-line "        }" fn)
  179. (write-line "        : column {" fn)
  180. (write-line "            spacer;" fn)
  181. (write-line "            spacer;" fn)
  182. (write-line "            : button {" fn)
  183. (write-line "                label = \"添加文件夹...\";" fn)
  184. (write-line "                key = \"but_addfolder\";" fn)
  185. (write-line "                fixed_width = true;" fn)
  186. (write-line "            }" fn)
  187. (write-line "            : toggle {" fn)
  188. (write-line "                label = \"包括子文件夹\";" fn)
  189. (write-line "                key = \"tog_subfolder\";" fn)
  190. (write-line "            }" fn)
  191. (write-line "            : button {" fn)
  192. (write-line "                label = \"添加文件...\";" fn)
  193. (write-line "                key = \"but_addfile\";" fn)
  194. (write-line "            }" fn)
  195. (write-line "            : button {" fn)
  196. (write-line "                label = \"删除...\";" fn)
  197. (write-line "                key = \"but_del\";" fn)
  198. (write-line "                is_enabled = false;" fn)
  199. (write-line "            }" fn)
  200. (write-line "            : button {" fn)
  201. (write-line "                label = \"确定(&A)\";" fn)
  202. (write-line "                key = \"but_OK\";" fn)
  203. (write-line "                is_enabled = false;" fn)
  204. (write-line "                //is_default = true;" fn)
  205. (write-line "            }" fn)
  206. (write-line "            : button {" fn)
  207. (write-line "                label = \"取消(&C)\";" fn)
  208. (write-line "                key = \"but_Cancel\";" fn)
  209. (write-line "                is_cancel = true;" fn)
  210. (write-line "            }" fn)
  211. (write-line "            spacer;" fn)
  212. (write-line "            spacer;" fn)
  213. (write-line "            spacer;" fn)
  214. (write-line "       }" fn)
  215. (write-line "    }" fn)
  216. (write-line "}" fn)
  217. (write-line "" fn)
  218.   (close fn)
  219.   (setq fn (open fname "r"))
  220.   (setq dclid (load_dialog fname))
  221.   (while (or (eq (substr (setq lin (vl-string-right-trim "\" fn)" (vl-string-left-trim "(write-line \"" (read-line fn)))) 1 2) "//") (eq (substr lin 1 (vl-string-search " " lin)) "") (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9) " : dialog"))))
  222.   (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
  223.     ;;子文件夹
  224.     (start_list "pop_ver")
  225.     (mapcar 'add_list (mapcar '(lambda (x) (cadr x)) DwgType))
  226.     (end_list)
  227.     (if  (not pop_ver)
  228.       (setq pop_ver "0")
  229.     )
  230.     (set_tile "pop_ver" pop_ver)

  231.     ;;子文件夹
  232.     (if  (not tog_subfolder)
  233.       (setq tog_subfolder "0")
  234.     )
  235.     (set_tile "tog_subfolder" tog_subfolder)

  236.     (action_tile "pop_ver" "(setq pop_ver $value)")
  237.     (action_tile "but_addfolder" "(AddDwgFilesInFolder)")
  238.     (action_tile "but_addfile" "(AddDwgFiles)")
  239.     (action_tile "but_del" "(RemoveDwgFiles)")
  240.     (action_tile "tog_subfolder" "(setq tog_subfolder $value)")
  241.     (action_tile
  242.       "lst_DwgFile"
  243.       "(setq lst_DwgFile $value)(DelBtnIsEnabled)"
  244.     )
  245.     (action_tile "but_OK" "(setq pass T)(done_dialog 1)")
  246.     (action_tile "but_Cancel" "(done_dialog 0)")
  247.       (setq return# (start_dialog))
  248.   (princ return#)
  249.   (unload_dialog dclid)
  250.   (close fn)
  251.   (vl-file-delete fname)
  252.   (princ)
  253. )        ;end defun

  254.   ;;===========定义容错函数===============
  255.   (defun MyError (msg)
  256.     (if  (or (= msg "Function cancelled")
  257.       (= msg "quit / exit abort")
  258.       (= msg "函数被取消")
  259.       (= msg "函数已取消")
  260.   )
  261.       (princ)
  262.       (princ (strcat "\n 错误:" msg "\n"))
  263.     )
  264.     (setvar "acadlspasdoc" HOLDLSP)
  265.     (princ)
  266.   )

  267.   ;;=======================主函数===========
  268.   (setq  OldError *error*
  269.   *error*   MyError
  270.   )
  271.   (if (not MsgBox)
  272.     (load "MsgBox")
  273.   )
  274.   (cond
  275.     ((< (atof (getvar "acadver")) 16)  ;检查版本
  276.      (MsgBox "版本检查"
  277.        (+ vbOKOnly vbInformation)
  278.        "此程序只能运行在AutoCAD 2004或更高版本!"
  279.      )
  280.      (exit)
  281.     )
  282.     ((= 1 (getvar "dwgtitled"))    ;检查使用文件环境
  283.      (MsgBox "使用环境检查"
  284.        (+ vbOKOnly vbInformation)
  285.        "该程序只能在未保存的文件中运行!"
  286.      )
  287.      (exit)
  288.     )
  289.     ((not (setq dcl_id (load_dialog "dwgconverter")))
  290.      (MsgBox "无法加载对话框文件!"
  291.        (+ vbOKOnly vbInformation)
  292.        "数据检查"
  293.      )
  294.      (exit)
  295.     )
  296.   )          ;end cond

  297.   (setq  Initdir  (getvar "dwgprefix")
  298.   pass  nil
  299.   )
  300.   (cond
  301.     ((or (= (atof (getvar "acadver")) 16.0) (= (atof (getvar "acadver")) 16.1) (= (atof (getvar "acadver")) 16.2))
  302.      (setq DwgType (list (list 0 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
  303.              (list 1 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
  304.              (list 2 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
  305.              (list 3 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
  306.        )
  307.      )
  308.     )
  309.     ((or (= (atof (getvar "acadver")) 17.0) (= (atof (getvar "acadver")) 17.1) (= (atof (getvar "acadver")) 17.2))
  310.      (setq DwgType (list (list 0 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg)
  311.              (list 1 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf)
  312.              (list 2 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
  313.              (list 3 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
  314.              (list 4 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
  315.              (list 5 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
  316.              (list 6 "AutoCAD R14 DWG (*.dxf)" acR14_dxg)
  317.        )
  318.      )
  319.     )
  320.     ((= (atof (getvar "acadver")) 18.0)
  321.      (setq DwgType (list (list 0 "AutoCAD 2010 DWG (*.dwg)" ac2010_dwg)
  322.              (list 1 "AutoCAD 2010 DXF (*.dxf)" ac2010_dxf)
  323.              (list 2 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg)
  324.              (list 3 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf)
  325.              (list 4 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
  326.              (list 5 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
  327.              (list 6 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
  328.              (list 7 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
  329.              (list 8 "AutoCAD R14 DWG (*.dxf)" acR14_dxg)
  330.        )      
  331.      )
  332.     )
  333.     ((= (atof (getvar "acadver")) 18.1)
  334.      (setq DwgType (list (list 0 "AutoCAD 2010 DWG (*.dwg)" ac2010_dwg)
  335.              (list 1 "AutoCAD 2010 DXF (*.dxf)" ac2010_dxf)
  336.              (list 2 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg)
  337.              (list 3 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf)
  338.              (list 4 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
  339.              (list 5 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
  340.              (list 6 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
  341.              (list 7 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
  342.              (list 8 "AutoCAD R14 DWG (*.dxf)" acR14_dxg)
  343.        )      
  344.      )
  345.     )
  346.     ((= (atof (getvar "acadver")) 18.2)
  347.      (setq DwgType (list (list 0 "AutoCAD 2010 DWG (*.dwg)" ac2010_dwg)
  348.              (list 1 "AutoCAD 2010 DXF (*.dxf)" ac2010_dxf)
  349.              (list 2 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg)
  350.              (list 3 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf)
  351.              (list 4 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
  352.              (list 5 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
  353.              (list 6 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
  354.              (list 7 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
  355.              (list 8 "AutoCAD R14 DWG (*.dxf)" acR14_dxg)
  356.        )      ;这里为什么用list而不用 ',是因为用'后,ac2012_dwg等就不会求值了,导致后续程序取值错误
  357.      )
  358.     )
  359.   )
  360.   ;;打开对话框控制函数
  361.   (ConvDwgLst)

  362.   (if (and pass (not (null dwgfileLst)))
  363.     (progn
  364.       (setq Index   0
  365.       HOLDLSP (getvar "ACADLSPASDOC")
  366.       AcadApp (vlax-get-acad-object)
  367.       pop_ver (atoi pop_ver)
  368.       DwgVer  (last (dxf pop_ver DwgType))
  369.       )
  370.       (if (or (= pop_ver 1) (= pop_ver 3) (= pop_ver 5) (= pop_ver 7) (= pop_ver 9))
  371.   (setq IsDxfExt T
  372.         FileExt ".dxf"
  373.   )
  374.   (setq IsDxfExt nil
  375.         FileExt ".dwg"
  376.   )
  377.       )
  378.       ;;(setvar "acadlspasdoc" 0)
  379.       (repeat (length dwgfileLst)
  380.   (setq DwgName  (nth Index dwgfileLst)
  381.         BaseName (vl-filename-base DwgName)
  382.         filepath (vl-filename-directory DwgName)
  383.         DxfFile  (strcat (getfullpath filepath)
  384.              BaseName
  385.              ".dxf"
  386.            )
  387.         NewFile  (vl-filename-mktemp BaseName filepath FileExt)
  388.         DocObj   (vla-open (vla-get-documents AcadApp) DwgName)
  389.   )
  390.   ;;将原dwg文件存为指定版本的
  391.   (vla-saveas DocObj NewFile DwgVer)
  392.   (vla-close DocObj :vlax-false)

  393.   (if IsDxfExt
  394.     (progn
  395.       ;;如果新文件后缀是dxf,就把dxf改为跟dwg同名文件
  396.       (if  (findfile DxfFile)
  397.         (deletefile DxfFile)
  398.       )
  399.       (vl-file-rename NewFile DxfFile)
  400.     )
  401.     (progn
  402.       ;;如果新文件后缀是dwg,就删除原dwg文件
  403.       (deletefile DwgName)
  404.       ;;再把新保存的文件名改为原dwg文件名
  405.       (vl-file-rename NewFile DwgName)
  406.     )
  407.   )
  408.   (setq Index (1+ Index))
  409.       )          ;end repeat

  410.       (setvar "acadlspasdoc" HOLDLSP)
  411.       (if DocObj
  412.   (vlax-release-object DocObj)
  413.       )
  414.       (if AcadApp
  415.   (vlax-release-object AcadApp)
  416.       )
  417.     )          ;end progn
  418.   )          ;end if

  419.   (setq *error* OldError)
  420.   (princ)

  421. )          ;end defun

  422. ;;=================dwg转dxf文件函数================
  423. (defun Dwg2Dxf (DwgName dxfName / AcadApp dbxDoc)
  424.   (setq  AcadApp  (vlax-get-acad-object)
  425.   dbxDoc  (vla-GetInterfaceObject
  426.       AcadApp
  427.       (GetObjectDBXVer)
  428.     )
  429.   )
  430.   (vla-open dbxDoc DwgName)
  431.   (vlax-invoke dbxDoc "dxfout" dxfName)
  432.   (if dbxDoc
  433.     (vlax-release-object dbxDoc)
  434.   )          ;关闭文档
  435.   (if AcadApp
  436.     (vlax-release-object AcadApp)
  437.   )
  438. )          ;end defun

  439. ;;========================去除教育版标记================================
  440. (defun C:Deljyb (/    pass      dcl_id  OldError
  441.         DxfExt  Initdir      BackUp  HOLDLSP
  442.         AcadApp  DocObj      Index  DwgName
  443.         BaseName  filepath    dxfFile  BackupFile
  444.         dwgfileLst  lst_DwgFile tog_subfolder
  445.        )
  446.   ;;============加载dwg文件到列表==============
  447.   (defun LoadDwgFileLst  (fileslst / HasOpenFiles)
  448.     (if  fileslst
  449.       (progn
  450.   (if dwgfileLst
  451.     (progn
  452.       (mapcar '(lambda (tmpfile)
  453.            (setq dwgfileLst
  454.             (vl-remove (strcase tmpfile T) dwgfileLst)
  455.            )
  456.          )
  457.         fileslst
  458.       )
  459.       (setq dwgfileLst (append dwgfileLst fileslst))
  460.     )
  461.     (setq dwgfileLst fileslst)
  462.   )        ;end if
  463.   ;;检测文件是否打开
  464.   (setq HasOpenFiles (vl-remove-if 'VL-FILE-SYSTIME dwgfileLst)
  465.         dwgfileLst   (vl-remove-if-not 'VL-FILE-SYSTIME dwgfileLst)
  466.   )
  467.   (if dwgfileLst
  468.     (setq dwgfileLst (vl-sort dwgfileLst '<))
  469.   )
  470.   (if HasOpenFiles
  471.     (alert (strcat "以下文件已经被打开,无法添加到列表:\n"
  472.        (AddSeprate HasOpenFiles "\n")
  473.      )
  474.     )
  475.   )
  476.   (start_list "lst_DwgFile")
  477.   (mapcar 'add_list dwgfileLst)
  478.   (end_list)
  479.       )
  480.     )          ;end if
  481.     (OkBtnIsEnabled)
  482.   )          ;end defun

  483.   ;;============获取指定文件夹下的所有dwg文件=================
  484.   (defun AddDwgFilesInFolder (/ filter dwgPath dwgfiles)
  485.     (setq filter  "*.dwg"
  486.     dwgPath (GetFolderNew Initdir "选择DWG文件夹")
  487.     )
  488.     (if  dwgPath
  489.       (progn
  490.   (setq Initdir dwgPath)
  491.   (if (= "0" tog_subfolder)
  492.     (setq dwgfiles (GetAllSpecFilesInFolder dwgPath filter))
  493.     (setq dwgfiles (GetAllSpecFilesInFolders dwgPath filter))
  494.   )
  495.   (LoadDwgFileLst dwgfiles)
  496.       )
  497.     )
  498.   )          ;end defun

  499.   ;;===============获取选中的dwg文件=====================
  500.   (defun AddDwgFiles (/ flags diatl filter dwgfiles)
  501.     (setq flags   (+ 4 512 4096 32768 524288 1048576)
  502.     diatl   "选择文件"
  503.     filter "图形(*.dwg)|*.dwg"
  504.     )
  505.     (setq dwgfiles (GetMultiFiles flags diatl filter Initdir))
  506.     (if  dwgfiles
  507.       (progn
  508.   (setq Initdir (vl-filename-directory (car dwgfiles)))
  509.   (LoadDwgFileLst dwgfiles)
  510.       )
  511.     )
  512.   )          ;end defun

  513.   ;;=============移除按钮状态函数=======================
  514.   (defun DelBtnIsEnabled ()
  515.     (if  lst_DwgFile
  516.       (mode_tile "but_del" 0)
  517.       (mode_tile "but_del" 1)
  518.     )
  519.   )          ;end defun

  520.   ;;=============确认按钮是否激活函数=======================
  521.   (defun OkBtnIsEnabled  ()
  522.     (if  (null dwgfileLst)
  523.       (mode_tile "but_OK" 1)
  524.       (mode_tile "but_OK" 0)
  525.     )
  526.   )

  527.   ;;==============移除选定文件函数=======================
  528.   (defun RemoveDwgFiles  (/ IndexLst RemoveDwgLst)
  529.     (if  lst_DwgFile
  530.       (progn
  531.   (setq IndexLst     (makelist lst_DwgFile " ")
  532.         RemoveDwgLst (mapcar '(lambda (index)
  533.               (nth (atoi index) dwgfileLst)
  534.             )
  535.            IndexLst
  536.          )
  537.   )
  538.   ;;移除选定文件
  539.   (mapcar  '(lambda (tmpfile)
  540.        (setq dwgfileLst
  541.         (vl-remove (strcase tmpfile T) dwgfileLst)
  542.        )
  543.      )
  544.     RemoveDwgLst
  545.   )
  546.   (start_list "lst_DwgFile")
  547.   (mapcar 'add_list dwgfileLst)
  548.   (end_list)
  549.   (setq lst_DwgFile nil)
  550.       )
  551.     )          ;end if
  552.     (DelBtnIsEnabled)
  553.     (OkBtnIsEnabled)
  554.   )          ;end defun

  555.   ;;====================对话框驱动函数==========================
  556.   (defun GetEduDwgLst ( / fname fn dclid lin return# )
  557.   (setq fname (vl-filename-mktemp nil nil ".dcl"))
  558.   (setq fn (open fname "w"))
  559. (write-line "" fn)
  560. (write-line "dcl_settings : default_dcl_settings { audit_level = 3; }" fn)
  561. (write-line "" fn)(write-line "BatDelEdu : dialog {" fn)
  562. (write-line "    label = \"批量删除教育版标记\";" fn)
  563. (write-line "    : row {" fn)
  564. (write-line "        : boxed_column {" fn)
  565. (write-line "           label=\"DWG文件列表\";" fn)
  566. (write-line "           : list_box {" fn)
  567. (write-line "              //label=\"DWG文件列表\";" fn)
  568. (write-line "              key=\"lst_DwgFile\";" fn)
  569. (write-line "              width=70;" fn)
  570. (write-line "              height=35;" fn)
  571. (write-line "              allow_accept=true;" fn)
  572. (write-line "              multiple_select=true;" fn)
  573. (write-line "           }" fn)
  574. (write-line "        }        " fn)
  575. (write-line "        : column {" fn)
  576. (write-line "            spacer;" fn)
  577. (write-line "            spacer;" fn)
  578. (write-line "            : button {" fn)
  579. (write-line "                label = \"添加文件夹...\";" fn)
  580. (write-line "                key = \"but_addfolder\";" fn)
  581. (write-line "                fixed_width = true;" fn)
  582. (write-line "            }" fn)
  583. (write-line "            : toggle {" fn)
  584. (write-line "                label = \"包括子文件夹\";" fn)
  585. (write-line "                key = \"tog_subfolder\";" fn)
  586. (write-line "            }" fn)
  587. (write-line "            : button {" fn)
  588. (write-line "                label = \"添加文件...\";" fn)
  589. (write-line "                key = \"but_addfile\";" fn)
  590. (write-line "            }" fn)
  591. (write-line "            : button {" fn)
  592. (write-line "                label = \"删除...\";" fn)
  593. (write-line "                key = \"but_del\";" fn)
  594. (write-line "                is_enabled = false;" fn)
  595. (write-line "            }" fn)
  596. (write-line "            : button {" fn)
  597. (write-line "                label = \"确定(&A)\";" fn)
  598. (write-line "                key = \"but_OK\";" fn)
  599. (write-line "                is_enabled = false;" fn)
  600. (write-line "                //is_default = true;" fn)
  601. (write-line "            }" fn)
  602. (write-line "            : button {" fn)
  603. (write-line "                label = \"取消(&C)\";" fn)
  604. (write-line "                key = \"but_Cancel\";" fn)
  605. (write-line "                is_cancel = true;" fn)
  606. (write-line "            }" fn)
  607. (write-line "            spacer;" fn)
  608. (write-line "            spacer;" fn)
  609. (write-line "            spacer;" fn)
  610. (write-line "       }" fn)
  611. (write-line "    }" fn)
  612. (write-line "}" fn)
  613. (write-line "" fn)

  614. (close fn)
  615.   (setq fn (open fname "r"))
  616.   (setq dclid (load_dialog fname))
  617.   (while (or (eq (substr (setq lin (vl-string-right-trim "\" fn)" (vl-string-left-trim "(write-line \"" (read-line fn)))) 1 2) "//") (eq (substr lin 1 (vl-string-search " " lin)) "") (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9) " : dialog"))))
  618.   (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
  619.     ;;子文件夹
  620.     (if  (not tog_subfolder)
  621.       (setq tog_subfolder "0")
  622.     )
  623.     (set_tile "tog_subfolder" tog_subfolder)

  624.     (action_tile "but_addfolder" "(AddDwgFilesInFolder)")
  625.     (action_tile "but_addfile" "(AddDwgFiles)")
  626.     (action_tile "but_del" "(RemoveDwgFiles)")
  627.     (action_tile "tog_subfolder" "(setq tog_subfolder $value)")
  628.     (action_tile
  629.       "lst_DwgFile"
  630.       "(setq lst_DwgFile $value)(DelBtnIsEnabled)"
  631.     )
  632.     (action_tile "but_OK" "(setq pass T)(done_dialog 1)")
  633.     (action_tile "but_Cancel" "(done_dialog 0)")
  634.    (setq return# (start_dialog))
  635.   (princ return#)
  636.   (unload_dialog dclid)
  637.   (close fn)
  638.   (vl-file-delete fname)
  639.   (princ)
  640. )      ;end defun

  641.   ;;===========定义容错函数===============
  642.   (defun MyError (msg)
  643.     (if  (or (= msg "Function cancelled")
  644.       (= msg "quit / exit abort")
  645.       (= msg "函数被取消")
  646.       (= msg "函数已取消")
  647.   )
  648.       (princ)
  649.       (princ (strcat "\n 错误:" msg "\n"))
  650.     )
  651.     (setvar "acadlspasdoc" HOLDLSP)
  652.     (princ)
  653.   )

  654.   ;;=======================主函数===========
  655.   (setq  OldError *error*
  656.   *error*   MyError
  657.   )
  658.   (if (not MsgBox)
  659.     (load "MsgBox")
  660.   )
  661.   (cond
  662.     ((< (atof (getvar "acadver")) 16)  ;检查版本
  663.      (MsgBox "版本检查"
  664.        (+ vbOKOnly vbInformation)
  665.        "此程序只能运行在AutoCAD 2004或更高版本!"
  666.      )
  667.      (exit)
  668.     )
  669.     ((= 1 (getvar "dwgtitled"))    ;检查使用文件环境
  670.      (MsgBox "使用环境检查"
  671.        (+ vbOKOnly vbInformation)
  672.        "该程序只能在未保存的文件中运行!"
  673.      )
  674.      (exit)
  675.     )
  676.     ((not (setq dcl_id (load_dialog "dwgconverter")))
  677.      (MsgBox "无法加载对话框文件!"
  678.        (+ vbOKOnly vbInformation)
  679.        "数据检查"
  680.      )
  681.      (exit)
  682.     )
  683.   )          ;end cond

  684.   (setq  Initdir  (getvar "dwgprefix")
  685.   DxfExt  ".dxf"
  686.   BackUp  "_Backup"
  687.   pass  nil
  688.   )
  689.   ;;打开对话框控制函数
  690.   (GetEduDwgLst)

  691.   (if (and pass (not (null dwgfileLst)))
  692.     (progn
  693.       (setq Index   0
  694.       HOLDLSP (getvar "ACADLSPASDOC")
  695.       AcadApp (vlax-get-acad-object)
  696.       )
  697.       ;;(setvar "acadlspasdoc" 0)
  698.       (repeat (length dwgfileLst)
  699.   (setq DwgName   (nth Index dwgfileLst)
  700.         BaseName   (vl-filename-base DwgName)
  701.         filepath   (vl-filename-directory DwgName)
  702.         dxfFile   (vl-filename-mktemp BaseName filepath DxfExt)
  703.         BackupFile (strcat (getfullpath filepath)
  704.          BaseName
  705.          BackUp
  706.          (vl-filename-extension DwgName)
  707.        )
  708.        ;;以下语句直接打开会有“ 解密数据时出错”提示,导致不能打开文件
  709.        ;;因此改为用objectdbx转存为dxf文件,在打开dxf保存为dwg文件
  710.        ;;DocObj   (vla-open (vla-get-documents AcadApp) DwgName)
  711.   )
  712.   ;;利用objectdbx转存文件
  713.   (Dwg2Dxf DwgName dxfFile)
  714.   ;;检查原dwg文件的备份文件名是否存在,如果存在,则删除
  715.   (if (findfile BackupFile)
  716.     (deletefile BackupFile)
  717.   )
  718.   ;;修改原dwg文件名
  719.   (vl-file-rename DwgName BackupFile)
  720.   ;;打开dxf文件
  721.   (setq DocObj (vla-open (vla-get-documents AcadApp) dxfFile))
  722.   ;;再存为2007版dwg文件
  723.   (vla-saveas DocObj DwgName ac2007_dwg)
  724.   (vla-close DocObj :vlax-false)
  725.   ;;删除dxf文件
  726.   (deletefile dxfFile)
  727.   (setq Index (1+ Index))
  728.       )          ;end repeat

  729.       (setvar "acadlspasdoc" HOLDLSP)
  730.       (if DocObj
  731.   (vlax-release-object DocObj)
  732.       )
  733.       (if AcadApp
  734.   (vlax-release-object AcadApp)
  735.       )
  736.     )          ;end progn
  737.   )          ;end if

  738.   (setq *error* OldError)
  739.   (princ)
  740. )          ;end defun

  741. ;;==============================公用函数==========================
  742. ;;;
  743. ;;=============获取全路径,即路径后有\=================================
  744. (defun GetFullPath (path)
  745.   (if (wcmatch path "*\\")
  746.     path
  747.     (strcat path "\\")
  748.   )
  749. )          ;end defun

  750. ;;;============================获取文件夹程序=================================
  751. ;;;根据Express tools是否安装决定使用哪一个函数
  752. (defun GetFolderNew (InitDir msg / ArxFile Apptitle)
  753.   (setq  Apptitle "浏览文件夹"
  754.   ArxFile   "acetutil.arx"
  755.   )
  756.   (if (findfile ArxFile)
  757.     (GetFolder3 Apptitle Msg InitDir)
  758.     (getFolder1 msg)
  759.   )
  760. )          ;end defun

  761. ;;;============================获取文件夹程序1=================================
  762. ;;来自于明经秋枫
  763. ;; 用法:(getFolder1 msg)
  764. ;; 例子:(getFolder1 "选择文件夹:")
  765. ;; 返回值:字符串,文件夹路径,如果点了cancel, 返回nil
  766. (defun GetFolder1 (msg / WinShell shFolder path catchit)
  767.       ;|===============================
  768. 3. 关于Shell.Application的使用
  769. 3.1、创建 Shell 对象
  770. var Shell = new ActiveXObject("Shell.Application");

  771. 3.2、使用 Shell 属性及方法

  772. Shell.Application
  773. Shell.Parent

  774. Shell.CascadeWindows()
  775. Shell.TileHorizontally()
  776. Shell.TileVertically()
  777. Shell.ControlPanelItem(sDir) /* 比如:sysdm.cpl */
  778. Shell.EjectPC()
  779. Shell.Explore(vDir)
  780. Shell.Open(vDir)
  781. Shell.FileRun()
  782. Shell.FindComputer()
  783. Shell.FindFiles()
  784. Shell.Help()
  785. Shell.MinimizeAll()
  786. Shell.UndoMinimizeALL()
  787. Shell.RefreshMenu()
  788. Shell.SetTime()
  789. Shell.TrayProperties()
  790. Shell.ShutdownWindows()
  791. Shell.Suspend()
  792. oWindows = Shell.Windows() /* 返回ShellWindows对象 */
  793. fFolder = Shell.NameSpace(vDir) /* 返回所打开的vDir的Folder对象 */
  794. oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [, vRootFolder]) /* 选择文件夹对话框 */
  795. /*示例:
  796. function BrowseFolder()
  797. {
  798. var Message = "清选择文件夹";

  799. var Shell = new ActiveXObject( "Shell.Application" );
  800. var Folder = Shell.BrowseForFolder(0,Message,0x0040,0x11);
  801. if(Folder != null)
  802. {
  803. Folder = Folder.items(); // 返回 FolderItems 对象
  804. Folder = Folder.item(); // 返回 Folderitem 对象
  805. Folder = Folder.Path; // 返回路径
  806. if(Folder.charAt(varFolder.length-1) != "\\"){
  807. Folder = varFolder + "\\";
  808. }
  809. return Folder;
  810. }
  811. }
  812. */

  813. /*示例:
  814. var Folder = Shell.NameSpace("C:\\"); // 返回 Folder对象
  815. */
  816. |;

  817.   (setq winshell (vlax-create-object "Shell.Application"))
  818.   (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
  819.   (setq
  820.     catchit (vl-catch-all-apply
  821.         '(lambda ()
  822.      (setq shFolder (vlax-get-property shFolder 'self))
  823.      (setq path (vlax-get-property shFolder 'path))
  824.          )
  825.       )
  826.   )
  827.   (if (vl-catch-all-error-p catchit)
  828.     nil
  829.     (GetFullPath path)
  830.   )
  831. )          ;end defun

  832. ;;;============================获取文件夹程序3=================================
  833. ;;;必须安装Express tools后才能使用
  834. (defun GetFolder3 (Apptitle Msg InitDir / ArxFile New_Path catchit)
  835.   (setq ArxFile "acetutil.arx")
  836.   (if (findfile ArxFile)
  837.     (arxload "acetutil.arx" NIL)
  838.     (exit)
  839.   )

  840.   (setq  catchit  (vl-catch-all-apply
  841.       '(lambda ()
  842.          (setq New_Path
  843.           (strcat
  844.             (strcase
  845.         (acet-ui-pickdir
  846.           Msg
  847.           (vl-string-right-trim "\\" InitDir)
  848.           Apptitle
  849.         )
  850.             )
  851.           )
  852.          )
  853.        )
  854.     )
  855.   )
  856.   (if (vl-catch-all-error-p catchit)
  857.     nil
  858.     (GetFullPath New_Path)
  859.   )
  860. )          ;end defun

  861. ;;============;;注册"MSComDlg.CommonDialog"=============================
  862. (defun Regdlg ()
  863.   (vl-registry-write
  864.     "HKEY_CLASSES_ROOT\\LICENSES\\4d553650-6abe-11cf-8adb-00aa00c00905"
  865.     ""
  866.     "gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj"
  867.   )
  868. )          ;end defun

  869. ;;=========================vlisp如何打开多重选择文件对话框函数========================
  870. ;;来自于明经
  871. ;;调用示例
  872. ;|(defun C:msfile  (/ flags diatl filter initdir)
  873.   (setq  flags  (+ 4 512 4096 32768 524288 1048576)
  874.   diatl  "选择文件"
  875.   filter  "图形文件(*.dwg)|*.dwg|所有文件(*.*)|*.*"
  876.   initdir  (getvar "dwgprefix")
  877.   )
  878.   (GetMultiFiles flags diatl filter initdir)
  879. )          ;end defun
  880. |;
  881. (defun GetMultiFiles (flags  diatl    filter    initdir   /
  882.           index  wincomdlg filem      mfile     catchit
  883.          )
  884.   ;;首先判断是否已经注册,如果未注册,先注册,此操作需要重新启动CAD
  885.   (if (setq wincomdlg (vlax-create-object "MSComDlg.CommonDialog"))
  886.     (progn
  887.       (vlax-put-property wincomdlg 'CancelError :vlax-true)
  888.       (vlax-put-property wincomdlg 'MaxFileSize 32767)
  889.       (vlax-put-property
  890.   wincomdlg
  891.   'Flags
  892.   flags
  893.       )
  894.       (vlax-put-property wincomdlg 'DialogTitle diatl)
  895.       (vlax-put-property wincomdlg 'Filter filter)
  896.       (vlax-put-property wincomdlg 'InitDir initdir)
  897.       (setq
  898.   catchit  (vl-catch-all-apply  ;捕获错误
  899.       '(lambda ()
  900.          (vlax-invoke-method wincomdlg 'ShowOpen)
  901.          (setq filem (vlax-get wincomdlg 'filename))
  902.        )
  903.     )
  904.       )
  905.       (vlax-release-object wincomdlg)
  906.       (if (vl-catch-all-error-p catchit)
  907.   nil        ;此时选择的是取消
  908.   (progn
  909.     (setq  Index 1
  910.     filem (FSTR->LST filem)
  911.     )
  912.     (if filem
  913.       (if  (= 2 (length filem))
  914.         (setq
  915.     mfile
  916.      (list (strcase (strcat (car filem) (cadr filem)) T)
  917.      )
  918.         )
  919.         (repeat (1- (length filem))
  920.     (setq mfile (append
  921.             mfile
  922.             (list (strcase
  923.               (strcat (car filem)
  924.                 "\\"
  925.                 (nth index filem)
  926.               )
  927.               T
  928.             )
  929.             )
  930.           )
  931.           index (1+ index)
  932.     )
  933.         )        ;end repeat
  934.       )        ;end if
  935.     )        ;end if
  936.   )        ;end progn
  937.       )          ;end if
  938.     )
  939.     (progn
  940.       (alert "当前系统无MSComDlg.CommonDialog对象!")
  941.       (Regdlg)
  942.     )
  943.   )
  944.   mfile          ;返回值
  945. )          ;end defun

  946. ;;============将输入的数据转换为字符串列表===================
  947. (defun FSTR->LST (FM / N ff)
  948.   (setq FF NIL)
  949.   (IF (VL-STRING-POSITION (ASCII "\000") FM)
  950.     (PROGN
  951.       (WHILE (VL-STRING-POSITION (ASCII "\000") FM)
  952.   (SETQ N (VL-STRING-POSITION (ASCII "\000") FM))
  953.   (SETQ FF (APPEND FF (LIST (SUBSTR FM 1 N))))
  954.   (SETQ FM (SUBSTR FM (+ N 2) (- (STRLEN FM) N 1)))
  955.       )
  956.       (SETQ FF (APPEND FF (LIST FM)))
  957.     )
  958.     (PROGN
  959.       (SETQ FF (VL-FILENAME-DIRECTORY FM))
  960.       (SETQ FF (LIST FF (VL-STRING-SUBST "" FF FM)))
  961.     )
  962.   )
  963. )          ;end defun

  964. ;;=============获取指定文件夹(不包括子文件夹)下所有满足扩展名的文件===========
  965. ;;返回列表文件表元素全为小写
  966. (defun GetAllSpecFilesInFolder (dir filter)
  967.   (mapcar
  968.     (function
  969.       (lambda (file)
  970.   (strcase (strcat (getfullpath dir) file) T)
  971.       )
  972.     )
  973.     (vl-directory-files dir filter 1)
  974.   )
  975. )          ;end defun

  976. ;;=============获取指定文件夹(包括子文件夹)下所有满足扩展名的文件===========
  977. (defun GetAllSpecFilesInFolders  (dir filter / filenames)
  978.   (setq  filenames (mapcar
  979.         (function
  980.           (lambda (file)
  981.       (strcase (strcat (getfullpath dir) file) T)
  982.       ;;递归出口
  983.           )
  984.         )
  985.         (vl-directory-files dir filter 1)
  986.       )
  987.   )
  988.   (mapcar
  989.     (function
  990.       (lambda (subdir)
  991.   ;; 此处递归
  992.   (setq filenames  (append  filenames
  993.         (GetAllSpecFilesInFolders
  994.           (strcat (getfullpath dir) subdir)
  995.           filter
  996.         )
  997.       )
  998.   )
  999.       )
  1000.     )
  1001.     (vl-remove-if
  1002.       (function  (lambda  (subdir)
  1003.       (member subdir '("." ".."))
  1004.     )
  1005.       )
  1006.       (vl-directory-files dir nil -1)
  1007.     )
  1008.   )

  1009.   filenames
  1010. )          ;end defun

  1011. ;;;定义VB中对话框msgbox几个输入常数:全局变量
  1012. ;; MsgBox(prompt[, buttons][, title][, helpfile, context])
  1013. ;; Buttons:
  1014. ;; vbOKOnly          0 Display OK button only.
  1015. ;; vbOKCancel        1 Display OK and Cancel buttons.
  1016. ;; vbAbortRetryIgnore      2 Display Abort, Retry, and Ignore buttons.
  1017. ;; vbYesNoCancel        3 Display Yes, No, and Cancel buttons.
  1018. ;; vbYesNo          4 Display Yes and No buttons.
  1019. ;; vbRetryCancel        5 Display Retry and Cancel buttons.
  1020. ;; vbCritical       16 Display Critical Message icon.
  1021. ;; vbQuestion       32 Display Warning Query icon.
  1022. ;; vbExclamation       48 Display Warning Message icon.
  1023. ;; vbInformation       64 Display Information Message icon.
  1024. ;; vbDefaultButton1        0 First button is default.
  1025. ;; vbDefaultButton2      256 Second button is default.
  1026. ;; vbDefaultButton3      512 Third button is default.
  1027. ;; vbDefaultButton4      768 Fourth button is default.
  1028. ;; vbApplicationModal      0 Application modal; the user must respond to the message box before continuing work in the current application.
  1029. ;; vbSystemModal     4096 System modal; all applications are suspended until the user responds to the message box.
  1030. (setq vbOKOnly 0)
  1031. (setq vbOKCancel 1)
  1032. (setq vbAbortRetryIgnore 2)
  1033. (setq vbYesNoCancel 3)
  1034. (setq vbYesNo 4)
  1035. (setq vbRetryCancel 5)
  1036. (setq vbCritical 16
  1037.       vbQuestion 32
  1038. )
  1039. (setq vbExclamation   48
  1040.       vbInformation   64
  1041.       vbDefaultButton1   0
  1042.       vbDefaultButton2   256
  1043.       vbDefaultButton3   512
  1044.       vbDefaultButton4   768
  1045.       vbApplicationModal 0
  1046.       vbSystemModal   4096
  1047. )
  1048. ;;返回值
  1049. ;;1  OK button
  1050. ;;2  Cancel button
  1051. ;;3  Abort button
  1052. ;;4  Retry button
  1053. ;;5  Ignore button
  1054. ;;6  Yes button
  1055. ;;7  No button
  1056. (setq rs_OK 1
  1057.       rs_Cancel  2
  1058.       rs_Abort 3
  1059.       rs_Retry 4
  1060.       rs_Ignore  5
  1061.       rs_Yes 6
  1062.       rs_No 7
  1063. )

  1064. ;; A cute little utility to invoke a VBA message box and return a value to AutoLisp.
  1065. ;; Requires AutoCAD 2000 (R15) or higher.
  1066. ;; The buttons are a Boolean value representing a logical sum of
  1067. ;; the following values:
  1068. ;;--------------------------------------------------------
  1069. ;; MsgBox(prompt[, buttons][, title][, helpfile, context])
  1070. ;; Buttons:
  1071. ;; vbOKOnly          0 Display OK button only.
  1072. ;; vbOKCancel        1 Display OK and Cancel buttons.
  1073. ;; vbAbortRetryIgnore      2 Display Abort, Retry, and Ignore buttons.
  1074. ;; vbYesNoCancel        3 Display Yes, No, and Cancel buttons.
  1075. ;; vbYesNo          4 Display Yes and No buttons.
  1076. ;; vbRetryCancel        5 Display Retry and Cancel buttons.
  1077. ;; vbCritical       16 Display Critical Message icon.
  1078. ;; vbQuestion       32 Display Warning Query icon.
  1079. ;; vbExclamation       48 Display Warning Message icon.
  1080. ;; vbInformation       64 Display Information Message icon.
  1081. ;; vbDefaultButton1        0 First button is default.
  1082. ;; vbDefaultButton2      256 Second button is default.
  1083. ;; vbDefaultButton3      512 Third button is default.
  1084. ;; vbDefaultButton4      768 Fourth button is default.
  1085. ;; vbApplicationModal      0 Application modal; the user must respond to the message box before continuing work in the current application.
  1086. ;; vbSystemModal     4096 System modal; all applications are suspended until the user responds to the message box.
  1087. ;;test:(MsgBox "This is a test!" vbOKCancel "Iceberg CAD Tools")
  1088. (defun MsgBox (Title Buttons Message / useri1 value)
  1089.   (vl-load-com)
  1090.   (or *acad* (setq *acad* (vlax-get-acad-object)))
  1091.   (setq useri1 (getvar "useri1"))
  1092.   (acad-push-dbmod)
  1093.   (vla-eval
  1094.     *acad*
  1095.     (strcat
  1096.       "ThisDrawing.SetVariable \"USERI1\","
  1097.       "MsgBox (\""
  1098.       Message
  1099.       "\","
  1100.       (itoa Buttons)
  1101.       ",\""
  1102.       Title
  1103.       "\")"
  1104.     )
  1105.   )
  1106.   (setq value (getvar "useri1"))
  1107.   (setvar "useri1" useri1)
  1108.   (acad-pop-dbmod)
  1109.   value
  1110. )          ;end defun


  1111. ;;=========获取ObjectDBX版本字符串============
  1112. (defun GetObjectDBXVer (/ VERSION)
  1113.   (if (>= (setq VERSION (atoi (getvar "acadver"))) 16)
  1114.     (strcat "ObjectDBX.AxDbDocument." (itoa VERSION))
  1115.     nil
  1116.   )     ;end if
  1117. )     ;end defun

  1118. ;;;===========从图元表中提取dxf组码值函数组码值函数
  1119. (defun dxf (Item dxfList /) (cdr (assoc Item dxfList))) ;defun

  1120. ;;=================删除文件函数===================
  1121. ;; 能删除所有文件,不管只读、隐藏与否,都能删除
  1122. ;; vl-file-delete不能删除只读文件
  1123. ;;Scripting.FileSystemObject格式
  1124. ;;fso.DeleteFile ( filespec[, force] )
  1125. ;;参数
  1126. ;; fso  必选项, 应为 FileSystemObject 的名称。
  1127. ;; filespec 必选项, 要删除的文件的名称,filespec 可以在最后的路径成分中包含通配字符。
  1128. ;; force   可选项, Boolean 值,如果要删除设置了只读属性的文件,则为 true ;如果不删除则为 false (默认)。
  1129. ;; Arguments [Typ]:
  1130. ;;   Fil = FileName, "C:\\test\\Autoexec.bat" [STR]
  1131. ;; Notes:
  1132. ;;   - Requires ScrRun.dll.
  1133. ;; USAGE: (DelFile "C:\\test\\*.*")
  1134. ;; USAGE: (DelFile "C:\\test\\Autoexec.bat")
  1135. (defun DeleteFile (FIL / FILSYS FILDIR SS ENT)
  1136.   (setq FILSYS (vlax-create-object "Scripting.FileSystemObject"))
  1137.   (setq FILDIR (vl-filename-directory FIL))
  1138.   (setq
  1139.     SS (vl-directory-files
  1140.   FILDIR
  1141.   (strcat (vl-filename-base FIL) (vl-filename-extension FIL))
  1142.   1
  1143.        )
  1144.   )
  1145.   (foreach ENT SS
  1146.     (vlax-invoke
  1147.       FILSYS
  1148.       "deletefile"
  1149.       (strcat FILDIR "\\" ENT)
  1150.       :vlax-false
  1151.     )
  1152.   )
  1153.   (vlax-release-object FILSYS)
  1154.   (princ)
  1155. )   
  1156. ;end defun
  1157. (defun makelist        (str pat / i j n lst)
  1158. ;;生成表记录函数:把字符串变为表
  1159.    (cond
  1160.      ((/= (type str) (type pat) 'STR))
  1161.      ((= str pat) '(""))
  1162.      (T
  1163.       (setq i 0
  1164.             n (strlen pat)
  1165.       )
  1166.       (while (setq j (vl-string-search pat str i))
  1167.         (setq lst (cons (substr str (1+ i) (- j i)) lst)
  1168.               i         (+ j n)
  1169.         )
  1170.       )
  1171.       (reverse (cons (substr str (1+ i)) lst))
  1172.      )
  1173.    )
  1174. )

  1175. (defun GetObjectDBXVer (/ VERSION)
  1176.    (if (>= (setq VERSION (atoi (getvar "acadver"))) 16)
  1177.      (strcat "ObjectDBX.AxDbDocument." (itoa VERSION))
  1178.      nil
  1179.    )     ;end if
  1180. )     ;end defun

  1181. ;;;===========从图元表中提取dxf组码值函数组码值函数
  1182. (defun dxf (Item dxfList /) (cdr (assoc Item dxfList))) ;defun

  1183. ;;=================删除文件函数===================
  1184. ;; 能删除所有文件,不管只读、隐藏与否,都能删除
  1185. ;; vl-file-delete不能删除只读文件
  1186. ;;Scripting.FileSystemObject格式
  1187. ;;fso.DeleteFile ( filespec[, force] )
  1188. ;;参数
  1189. ;; fso  必选项, 应为 FileSystemObject 的名称。
  1190. ;; filespec 必选项, 要删除的文件的名称,filespec 可以在最后的路径成分中包含通配字符。
  1191. ;; force   可选项, Boolean 值,如果要删除设置了只读属性的文件,则为 true ;如果不删除则为 false (默认)。
  1192. ;; Arguments [Typ]:
  1193. ;;   Fil = FileName, "C:\\test\\Autoexec.bat" [STR]
  1194. ;; Notes:
  1195. ;;   - Requires ScrRun.dll.
  1196. ;; USAGE: (DelFile "C:\\test\\*.*")
  1197. ;; USAGE: (DelFile "C:\\test\\Autoexec.bat")
  1198. (defun DeleteFile (FIL / FILSYS FILDIR SS ENT)
  1199.    (setq FILSYS (vlax-create-object "Scripting.FileSystemObject"))
  1200.    (setq FILDIR (vl-filename-directory FIL))
  1201.    (setq
  1202.      SS (vl-directory-files
  1203.    FILDIR
  1204.    (strcat (vl-filename-base FIL) (vl-filename-extension FIL))
  1205.    1
  1206.         )
  1207.    )
  1208.    (foreach ENT SS
  1209.      (vlax-invoke
  1210.        FILSYS
  1211.        "deletefile"
  1212.        (strcat FILDIR "\\" ENT)
  1213.        :vlax-false
  1214.      )
  1215.    )
  1216.    (vlax-release-object FILSYS)
  1217.    (princ)
  1218. )     ;end defun


  1219. (defun AddSeprate (DataList delimiter / i len dealdata TempData)
  1220. ;;添加分隔符函数
  1221.    (setq i   1
  1222. len (length DataList)
  1223.    )
  1224.    (if len
  1225.      (progn
  1226.        (setq dealdata (nth 0 DataList))
  1227.        (if (numberp dealdata)
  1228. (setq dealdata (rtos dealdata 2))
  1229.        )
  1230.        (repeat (1- len)
  1231. (setq TempData (nth i DataList))
  1232. (if (numberp TempData)
  1233.     (setq TempData (rtos TempData 2))
  1234. )
  1235. (setq dealdata (strcat dealdata delimiter TempData))
  1236. (setq i (1+ i))
  1237.        )
  1238.      )
  1239.    )
  1240.    (setq DataList dealdata)
  1241. )

评分

参与人数 2明经币 +2 收起 理由
muwind + 1 很给力!
自贡黄明儒 + 1 这一修改很重要,感谢分享

查看全部评分

发表于 2012-12-16 05:30:51 | 显示全部楼层
非常感谢!!!!
发表于 2012-12-16 05:33:33 | 显示全部楼层
没有权限,很郁闷
发表于 2012-12-16 06:09:29 | 显示全部楼层
学习了很多用法。谢谢~
发表于 2012-12-31 09:40:48 | 显示全部楼层
本帖最后由 自贡黄明儒 于 2012-12-31 09:43 编辑
hehoubin 发表于 2012-12-9 18:36


1 是不是可以考虑加一个wblock命令,达到批量瘦身的作用?
2 或者加一个查找替换文字,就更完美了。
发表于 2012-12-31 11:37:39 | 显示全部楼层
hehoubin 发表于 2012-12-9 18:36

搞成如下的一个界面是不是更好?

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2013-1-1 21:14:01 | 显示全部楼层
谢谢 自贡黄明儒  发表于 昨天 11:37

学习了
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-12-23 05:51 , Processed in 0.171534 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表