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

fsz12378 · 发表于 2012-10-16 23:23

呵呵这样省事多了

pimgu · 发表于 2012-10-17 00:11

谢谢lz奉献

zhangzl · 发表于 2012-11-20 09:28

只能运行在2010以上的版本

hehoubin · 发表于 2012-12-9 18:36

;;DWG文件版本批量转换程序命令 DwgConverter
;;DWG文件去除教育版标记命令 DelEduLog
;;程序源码来自明经CAD iceberg2509 于2011.10.18
;;xiaoyingzi修改成支持autocad2004~2010
;;=================DWG文件版本批量转换程序=====================
(defun C:Dwgbbzh (/ pass DwgVer DwgType
dcl_id pop_ver OldError FileExt
IsDxfExt Initdir HOLDLSP AcadApp
DocObj Index DwgName BaseName
filepath DxfFile NewFile dwgfileLst
lst_DwgFile tog_subfolder
)
;|
object.SaveAsType
object PreferencesOpenSave
The object this property applies to.
SaveAsType
acSaveAsType enum; read-write
acR14_dwg AutoCAD R14 DWG (*.dwg)
ac2000_dwg AutoCAD 2000 DWG (*.dwg)
ac2000_dxf AutoCAD 2000 DXF (*.dxf)
ac2000_Template AutoCAD 2000 Drawing Template File (*.dwt)
ac2004_dwg AutoCAD 2004 DWG (*.dwg)
ac2004_dxf AutoCAD 2004 DXF (*.dxf)
ac2004_Template AutoCAD 2004 Drawing Template File (*.dwt)
ac2007_dwg AutoCAD 2007 DWG (*.dwg)
ac2007_dxf AutoCAD 2007 DXF (*.dxf)
ac2007_Template AutoCAD 2007 Drawing Template File (*.dwt)
ac2010_dwg AutoCAD 2010 DWG (*.dwg)
ac2010_dxf AutoCAD 2010 DXF (*.dxf)
ac2010_Template AutoCAD 2010 Drawing Template File (*.dwt)
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.
AcUnknown Read-only. The drawing type is unknown or invalid.
Remarks
The initial value for this property is ac2010_dwg. The following values are obsolete: acR13_DWG, acR13_DXF, acR14_DWG, and acR14_DXF.
|;
;;Sub DxfOut(ByVal FileName As String, Optional ByVal precision As Variant, Optional ByVal SaveThumbnailImage As Variant)
;;Sub SaveAs(ByVal FileName As String, Optional ByVal vSecurityParams As Variant)
;;Sub Open (ByVal FileName As String, Optional ByVal Password As Variant)
;;============加载dwg文件到列表==============
(defun LoadDwgFileLst (fileslst / HasOpenFiles)
(if fileslst
(progn
(if dwgfileLst
(progn
(mapcar '(lambda (tmpfile)
(setq dwgfileLst
(vl-remove (strcase tmpfile T) dwgfileLst)
)
)
fileslst
)
(setq dwgfileLst (append dwgfileLst fileslst))
)
(setq dwgfileLst fileslst)
) ;end if
;;检测文件是否打开
(setq HasOpenFiles (vl-remove-if 'VL-FILE-SYSTIME dwgfileLst)
dwgfileLst (vl-remove-if-not 'VL-FILE-SYSTIME dwgfileLst)
)
(if dwgfileLst
(setq dwgfileLst (vl-sort dwgfileLst '<))
)
(if HasOpenFiles
(alert (strcat "以下文件已经被打开，无法添加到列表：\n"
(AddSeprate HasOpenFiles "\n")
)
)
)
(start_list "lst_DwgFile")
(mapcar 'add_list dwgfileLst)
(end_list)
)
) ;end if
(OkBtnIsEnabled)
) ;end defun
;;============获取指定文件夹下的所有dwg文件=================
(defun AddDwgFilesInFolder (/ filter dwgPath dwgfiles)
(setq filter "*.dwg"
dwgPath (GetFolderNew Initdir "选择DWG文件夹")
)
(if dwgPath
(progn
(setq Initdir dwgPath)
(if (= "0" tog_subfolder)
(setq dwgfiles (GetAllSpecFilesInFolder dwgPath filter))
(setq dwgfiles (GetAllSpecFilesInFolders dwgPath filter))
)
(LoadDwgFileLst dwgfiles)
)
)
) ;end defun
;;===============获取选中的dwg文件=====================
(defun AddDwgFiles (/ flags diatl filter dwgfiles)
(setq flags (+ 4 512 4096 32768 524288 1048576)
diatl "选择文件"
filter "图形(*.dwg)|*.dwg"
)
(setq dwgfiles (GetMultiFiles flags diatl filter Initdir))
(if dwgfiles
(progn
(setq Initdir (vl-filename-directory (car dwgfiles)))
(LoadDwgFileLst dwgfiles)
)
)
) ;end defun
;;=============移除按钮状态函数=======================
(defun DelBtnIsEnabled ()
(if lst_DwgFile
(mode_tile "but_del" 0)
(mode_tile "but_del" 1)
)
) ;end defun
;;=============确认按钮是否激活函数=======================
(defun OkBtnIsEnabled ()
(if (null dwgfileLst)
(mode_tile "but_OK" 1)
(mode_tile "but_OK" 0)
)
)
;;==============移除选定文件函数=======================
(defun RemoveDwgFiles (/ IndexLst RemoveDwgLst)
(if lst_DwgFile
(progn
(setq IndexLst (makelist lst_DwgFile " ")
RemoveDwgLst (mapcar '(lambda (index)
(nth (atoi index) dwgfileLst)
)
IndexLst
)
)
;;移除选定文件
(mapcar '(lambda (tmpfile)
(setq dwgfileLst
(vl-remove (strcase tmpfile T) dwgfileLst)
)
)
RemoveDwgLst
)
(start_list "lst_DwgFile")
(mapcar 'add_list dwgfileLst)
(end_list)
(setq lst_DwgFile nil)
)
) ;end if
(DelBtnIsEnabled)
(OkBtnIsEnabled)
) ;end defun
;;====================对话框驱动函数==========================
(defun ConvDwgLst ( / fname fn dclid lin return# )
(setq fname (vl-filename-mktemp nil nil ".dcl"))
(setq fn (open fname "w"))
(write-line "" fn)
(write-line "dcl_settings : default_dcl_settings { audit_level = 3; }" fn)
(write-line "" fn)
(write-line "" fn)
(write-line "BatConVer : dialog {" fn)
(write-line " label = \"批量转换DWG文件版本\";" fn)
(write-line " : row {" fn)
(write-line " : column {" fn)
(write-line " : boxed_row {" fn)
(write-line " label = \"转换版本\";" fn)
(write-line " : popup_list {" fn)
(write-line " key = \"pop_ver\";" fn)
(write-line " //width=36;" fn)
(write-line " }" fn)
(write-line " }" fn)
(write-line " : boxed_row {" fn)
(write-line " label=\"DWG文件列表\";" fn)
(write-line " : list_box { " fn)
(write-line " key=\"lst_DwgFile\";" fn)
(write-line " width=70;" fn)
(write-line " height=35;" fn)
(write-line " allow_accept=true;" fn)
(write-line " multiple_select=true;" fn)
(write-line " }" fn)
(write-line " }" fn)
(write-line " }" fn)
(write-line " : column {" fn)
(write-line " spacer;" fn)
(write-line " spacer;" fn)
(write-line " : button {" fn)
(write-line " label = \"添加文件夹...\";" fn)
(write-line " key = \"but_addfolder\";" fn)
(write-line " fixed_width = true;" fn)
(write-line " }" fn)
(write-line " : toggle {" fn)
(write-line " label = \"包括子文件夹\";" fn)
(write-line " key = \"tog_subfolder\";" fn)
(write-line " }" fn)
(write-line " : button {" fn)
(write-line " label = \"添加文件...\";" fn)
(write-line " key = \"but_addfile\";" fn)
(write-line " }" fn)
(write-line " : button {" fn)
(write-line " label = \"删除...\";" fn)
(write-line " key = \"but_del\";" fn)
(write-line " is_enabled = false;" fn)
(write-line " }" fn)
(write-line " : button {" fn)
(write-line " label = \"确定(&A)\";" fn)
(write-line " key = \"but_OK\";" fn)
(write-line " is_enabled = false;" fn)
(write-line " //is_default = true;" fn)
(write-line " }" fn)
(write-line " : button {" fn)
(write-line " label = \"取消(&C)\";" fn)
(write-line " key = \"but_Cancel\";" fn)
(write-line " is_cancel = true;" fn)
(write-line " }" fn)
(write-line " spacer;" fn)
(write-line " spacer;" fn)
(write-line " spacer;" fn)
(write-line " }" fn)
(write-line " }" fn)
(write-line "}" fn)
(write-line "" fn)
(close fn)
(setq fn (open fname "r"))
(setq dclid (load_dialog fname))
(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"))))
(new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
;;子文件夹
(start_list "pop_ver")
(mapcar 'add_list (mapcar '(lambda (x) (cadr x)) DwgType))
(end_list)
(if (not pop_ver)
(setq pop_ver "0")
)
(set_tile "pop_ver" pop_ver)
;;子文件夹
(if (not tog_subfolder)
(setq tog_subfolder "0")
)
(set_tile "tog_subfolder" tog_subfolder)
(action_tile "pop_ver" "(setq pop_ver $value)")
(action_tile "but_addfolder" "(AddDwgFilesInFolder)")
(action_tile "but_addfile" "(AddDwgFiles)")
(action_tile "but_del" "(RemoveDwgFiles)")
(action_tile "tog_subfolder" "(setq tog_subfolder $value)")
(action_tile
"lst_DwgFile"
"(setq lst_DwgFile $value)(DelBtnIsEnabled)"
)
(action_tile "but_OK" "(setq pass T)(done_dialog 1)")
(action_tile "but_Cancel" "(done_dialog 0)")
(setq return# (start_dialog))
(princ return#)
(unload_dialog dclid)
(close fn)
(vl-file-delete fname)
(princ)
) ;end defun
;;===========定义容错函数===============
(defun MyError (msg)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
(= msg "函数被取消")
(= msg "函数已取消")
)
(princ)
(princ (strcat "\n 错误:" msg "\n"))
)
(setvar "acadlspasdoc" HOLDLSP)
(princ)
)
;;=======================主函数===========
(setq OldError *error*
*error* MyError
)
(if (not MsgBox)
(load "MsgBox")
)
(cond
((< (atof (getvar "acadver")) 16) ;检查版本
(MsgBox "版本检查"
(+ vbOKOnly vbInformation)
"此程序只能运行在AutoCAD 2004或更高版本!"
)
(exit)
)
((= 1 (getvar "dwgtitled")) ;检查使用文件环境
(MsgBox "使用环境检查"
(+ vbOKOnly vbInformation)
"该程序只能在未保存的文件中运行！"
)
(exit)
)
((not (setq dcl_id (load_dialog "dwgconverter")))
(MsgBox "无法加载对话框文件！"
(+ vbOKOnly vbInformation)
"数据检查"
)
(exit)
)
) ;end cond
(setq Initdir (getvar "dwgprefix")
pass nil
)
(cond
((or (= (atof (getvar "acadver")) 16.0) (= (atof (getvar "acadver")) 16.1) (= (atof (getvar "acadver")) 16.2))
(setq DwgType (list (list 0 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
(list 1 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
(list 2 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
(list 3 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
)
)
)
((or (= (atof (getvar "acadver")) 17.0) (= (atof (getvar "acadver")) 17.1) (= (atof (getvar "acadver")) 17.2))
(setq DwgType (list (list 0 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg)
(list 1 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf)
(list 2 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
(list 3 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
(list 4 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
(list 5 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
(list 6 "AutoCAD R14 DWG (*.dxf)" acR14_dxg)
)
)
)
((= (atof (getvar "acadver")) 18.0)
(setq DwgType (list (list 0 "AutoCAD 2010 DWG (*.dwg)" ac2010_dwg)
(list 1 "AutoCAD 2010 DXF (*.dxf)" ac2010_dxf)
(list 2 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg)
(list 3 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf)
(list 4 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
(list 5 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
(list 6 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
(list 7 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
(list 8 "AutoCAD R14 DWG (*.dxf)" acR14_dxg)
)
)
)
((= (atof (getvar "acadver")) 18.1)
(setq DwgType (list (list 0 "AutoCAD 2010 DWG (*.dwg)" ac2010_dwg)
(list 1 "AutoCAD 2010 DXF (*.dxf)" ac2010_dxf)
(list 2 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg)
(list 3 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf)
(list 4 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
(list 5 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
(list 6 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
(list 7 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
(list 8 "AutoCAD R14 DWG (*.dxf)" acR14_dxg)
)
)
)
((= (atof (getvar "acadver")) 18.2)
(setq DwgType (list (list 0 "AutoCAD 2010 DWG (*.dwg)" ac2010_dwg)
(list 1 "AutoCAD 2010 DXF (*.dxf)" ac2010_dxf)
(list 2 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg)
(list 3 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf)
(list 4 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg)
(list 5 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf)
(list 6 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg)
(list 7 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf)
(list 8 "AutoCAD R14 DWG (*.dxf)" acR14_dxg)
) ;这里为什么用list而不用 '，是因为用'后，ac2012_dwg等就不会求值了，导致后续程序取值错误
)
)
)
;;打开对话框控制函数
(ConvDwgLst)
(if (and pass (not (null dwgfileLst)))
(progn
(setq Index 0
HOLDLSP (getvar "ACADLSPASDOC")
AcadApp (vlax-get-acad-object)
pop_ver (atoi pop_ver)
DwgVer (last (dxf pop_ver DwgType))
)
(if (or (= pop_ver 1) (= pop_ver 3) (= pop_ver 5) (= pop_ver 7) (= pop_ver 9))
(setq IsDxfExt T
FileExt ".dxf"
)
(setq IsDxfExt nil
FileExt ".dwg"
)
)
;;(setvar "acadlspasdoc" 0)
(repeat (length dwgfileLst)
(setq DwgName (nth Index dwgfileLst)
BaseName (vl-filename-base DwgName)
filepath (vl-filename-directory DwgName)
DxfFile (strcat (getfullpath filepath)
BaseName
".dxf"
)
NewFile (vl-filename-mktemp BaseName filepath FileExt)
DocObj (vla-open (vla-get-documents AcadApp) DwgName)
)
;;将原dwg文件存为指定版本的
(vla-saveas DocObj NewFile DwgVer)
(vla-close DocObj :vlax-false)
(if IsDxfExt
(progn
;;如果新文件后缀是dxf，就把dxf改为跟dwg同名文件
(if (findfile DxfFile)
(deletefile DxfFile)
)
(vl-file-rename NewFile DxfFile)
)
(progn
;;如果新文件后缀是dwg，就删除原dwg文件
(deletefile DwgName)
;;再把新保存的文件名改为原dwg文件名
(vl-file-rename NewFile DwgName)
)
)
(setq Index (1+ Index))
) ;end repeat
(setvar "acadlspasdoc" HOLDLSP)
(if DocObj
(vlax-release-object DocObj)
)
(if AcadApp
(vlax-release-object AcadApp)
)
) ;end progn
) ;end if
(setq *error* OldError)
(princ)
) ;end defun
;;=================dwg转dxf文件函数================
(defun Dwg2Dxf (DwgName dxfName / AcadApp dbxDoc)
(setq AcadApp (vlax-get-acad-object)
dbxDoc (vla-GetInterfaceObject
AcadApp
(GetObjectDBXVer)
)
)
(vla-open dbxDoc DwgName)
(vlax-invoke dbxDoc "dxfout" dxfName)
(if dbxDoc
(vlax-release-object dbxDoc)
) ;关闭文档
(if AcadApp
(vlax-release-object AcadApp)
)
) ;end defun
;;========================去除教育版标记================================
(defun C:Deljyb (/ pass dcl_id OldError
DxfExt Initdir BackUp HOLDLSP
AcadApp DocObj Index DwgName
BaseName filepath dxfFile BackupFile
dwgfileLst lst_DwgFile tog_subfolder
)
;;============加载dwg文件到列表==============
(defun LoadDwgFileLst (fileslst / HasOpenFiles)
(if fileslst
(progn
(if dwgfileLst
(progn
(mapcar '(lambda (tmpfile)
(setq dwgfileLst
(vl-remove (strcase tmpfile T) dwgfileLst)
)
)
fileslst
)
(setq dwgfileLst (append dwgfileLst fileslst))
)
(setq dwgfileLst fileslst)
) ;end if
;;检测文件是否打开
(setq HasOpenFiles (vl-remove-if 'VL-FILE-SYSTIME dwgfileLst)
dwgfileLst (vl-remove-if-not 'VL-FILE-SYSTIME dwgfileLst)
)
(if dwgfileLst
(setq dwgfileLst (vl-sort dwgfileLst '<))
)
(if HasOpenFiles
(alert (strcat "以下文件已经被打开，无法添加到列表：\n"
(AddSeprate HasOpenFiles "\n")
)
)
)
(start_list "lst_DwgFile")
(mapcar 'add_list dwgfileLst)
(end_list)
)
) ;end if
(OkBtnIsEnabled)
) ;end defun
;;============获取指定文件夹下的所有dwg文件=================
(defun AddDwgFilesInFolder (/ filter dwgPath dwgfiles)
(setq filter "*.dwg"
dwgPath (GetFolderNew Initdir "选择DWG文件夹")
)
(if dwgPath
(progn
(setq Initdir dwgPath)
(if (= "0" tog_subfolder)
(setq dwgfiles (GetAllSpecFilesInFolder dwgPath filter))
(setq dwgfiles (GetAllSpecFilesInFolders dwgPath filter))
)
(LoadDwgFileLst dwgfiles)
)
)
) ;end defun
;;===============获取选中的dwg文件=====================
(defun AddDwgFiles (/ flags diatl filter dwgfiles)
(setq flags (+ 4 512 4096 32768 524288 1048576)
diatl "选择文件"
filter "图形(*.dwg)|*.dwg"
)
(setq dwgfiles (GetMultiFiles flags diatl filter Initdir))
(if dwgfiles
(progn
(setq Initdir (vl-filename-directory (car dwgfiles)))
(LoadDwgFileLst dwgfiles)
)
)
) ;end defun
;;=============移除按钮状态函数=======================
(defun DelBtnIsEnabled ()
(if lst_DwgFile
(mode_tile "but_del" 0)
(mode_tile "but_del" 1)
)
) ;end defun
;;=============确认按钮是否激活函数=======================
(defun OkBtnIsEnabled ()
(if (null dwgfileLst)
(mode_tile "but_OK" 1)
(mode_tile "but_OK" 0)
)
)
;;==============移除选定文件函数=======================
(defun RemoveDwgFiles (/ IndexLst RemoveDwgLst)
(if lst_DwgFile
(progn
(setq IndexLst (makelist lst_DwgFile " ")
RemoveDwgLst (mapcar '(lambda (index)
(nth (atoi index) dwgfileLst)
)
IndexLst
)
)
;;移除选定文件
(mapcar '(lambda (tmpfile)
(setq dwgfileLst
(vl-remove (strcase tmpfile T) dwgfileLst)
)
)
RemoveDwgLst
)
(start_list "lst_DwgFile")
(mapcar 'add_list dwgfileLst)
(end_list)
(setq lst_DwgFile nil)
)
) ;end if
(DelBtnIsEnabled)
(OkBtnIsEnabled)
) ;end defun
;;====================对话框驱动函数==========================
(defun GetEduDwgLst ( / fname fn dclid lin return# )
(setq fname (vl-filename-mktemp nil nil ".dcl"))
(setq fn (open fname "w"))
(write-line "" fn)
(write-line "dcl_settings : default_dcl_settings { audit_level = 3; }" fn)
(write-line "" fn)(write-line "BatDelEdu : dialog {" fn)
(write-line " label = \"批量删除教育版标记\";" fn)
(write-line " : row {" fn)
(write-line " : boxed_column {" fn)
(write-line " label=\"DWG文件列表\";" fn)
(write-line " : list_box {" fn)
(write-line " //label=\"DWG文件列表\";" fn)
(write-line " key=\"lst_DwgFile\";" fn)
(write-line " width=70;" fn)
(write-line " height=35;" fn)
(write-line " allow_accept=true;" fn)
(write-line " multiple_select=true;" fn)
(write-line " }" fn)
(write-line " } " fn)
(write-line " : column {" fn)
(write-line " spacer;" fn)
(write-line " spacer;" fn)
(write-line " : button {" fn)
(write-line " label = \"添加文件夹...\";" fn)
(write-line " key = \"but_addfolder\";" fn)
(write-line " fixed_width = true;" fn)
(write-line " }" fn)
(write-line " : toggle {" fn)
(write-line " label = \"包括子文件夹\";" fn)
(write-line " key = \"tog_subfolder\";" fn)
(write-line " }" fn)
(write-line " : button {" fn)
(write-line " label = \"添加文件...\";" fn)
(write-line " key = \"but_addfile\";" fn)
(write-line " }" fn)
(write-line " : button {" fn)
(write-line " label = \"删除...\";" fn)
(write-line " key = \"but_del\";" fn)
(write-line " is_enabled = false;" fn)
(write-line " }" fn)
(write-line " : button {" fn)
(write-line " label = \"确定(&A)\";" fn)
(write-line " key = \"but_OK\";" fn)
(write-line " is_enabled = false;" fn)
(write-line " //is_default = true;" fn)
(write-line " }" fn)
(write-line " : button {" fn)
(write-line " label = \"取消(&C)\";" fn)
(write-line " key = \"but_Cancel\";" fn)
(write-line " is_cancel = true;" fn)
(write-line " }" fn)
(write-line " spacer;" fn)
(write-line " spacer;" fn)
(write-line " spacer;" fn)
(write-line " }" fn)
(write-line " }" fn)
(write-line "}" fn)
(write-line "" fn)
(close fn)
(setq fn (open fname "r"))
(setq dclid (load_dialog fname))
(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"))))
(new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
;;子文件夹
(if (not tog_subfolder)
(setq tog_subfolder "0")
)
(set_tile "tog_subfolder" tog_subfolder)
(action_tile "but_addfolder" "(AddDwgFilesInFolder)")
(action_tile "but_addfile" "(AddDwgFiles)")
(action_tile "but_del" "(RemoveDwgFiles)")
(action_tile "tog_subfolder" "(setq tog_subfolder $value)")
(action_tile
"lst_DwgFile"
"(setq lst_DwgFile $value)(DelBtnIsEnabled)"
)
(action_tile "but_OK" "(setq pass T)(done_dialog 1)")
(action_tile "but_Cancel" "(done_dialog 0)")
(setq return# (start_dialog))
(princ return#)
(unload_dialog dclid)
(close fn)
(vl-file-delete fname)
(princ)
) ;end defun
;;===========定义容错函数===============
(defun MyError (msg)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
(= msg "函数被取消")
(= msg "函数已取消")
)
(princ)
(princ (strcat "\n 错误:" msg "\n"))
)
(setvar "acadlspasdoc" HOLDLSP)
(princ)
)
;;=======================主函数===========
(setq OldError *error*
*error* MyError
)
(if (not MsgBox)
(load "MsgBox")
)
(cond
((< (atof (getvar "acadver")) 16) ;检查版本
(MsgBox "版本检查"
(+ vbOKOnly vbInformation)
"此程序只能运行在AutoCAD 2004或更高版本!"
)
(exit)
)
((= 1 (getvar "dwgtitled")) ;检查使用文件环境
(MsgBox "使用环境检查"
(+ vbOKOnly vbInformation)
"该程序只能在未保存的文件中运行！"
)
(exit)
)
((not (setq dcl_id (load_dialog "dwgconverter")))
(MsgBox "无法加载对话框文件！"
(+ vbOKOnly vbInformation)
"数据检查"
)
(exit)
)
) ;end cond
(setq Initdir (getvar "dwgprefix")
DxfExt ".dxf"
BackUp "_Backup"
pass nil
)
;;打开对话框控制函数
(GetEduDwgLst)
(if (and pass (not (null dwgfileLst)))
(progn
(setq Index 0
HOLDLSP (getvar "ACADLSPASDOC")
AcadApp (vlax-get-acad-object)
)
;;(setvar "acadlspasdoc" 0)
(repeat (length dwgfileLst)
(setq DwgName (nth Index dwgfileLst)
BaseName (vl-filename-base DwgName)
filepath (vl-filename-directory DwgName)
dxfFile (vl-filename-mktemp BaseName filepath DxfExt)
BackupFile (strcat (getfullpath filepath)
BaseName
BackUp
(vl-filename-extension DwgName)
)
;;以下语句直接打开会有“ 解密数据时出错”提示，导致不能打开文件
;;因此改为用objectdbx转存为dxf文件，在打开dxf保存为dwg文件
;;DocObj (vla-open (vla-get-documents AcadApp) DwgName)
)
;;利用objectdbx转存文件
(Dwg2Dxf DwgName dxfFile)
;;检查原dwg文件的备份文件名是否存在，如果存在，则删除
(if (findfile BackupFile)
(deletefile BackupFile)
)
;;修改原dwg文件名
(vl-file-rename DwgName BackupFile)
;;打开dxf文件
(setq DocObj (vla-open (vla-get-documents AcadApp) dxfFile))
;;再存为2007版dwg文件
(vla-saveas DocObj DwgName ac2007_dwg)
(vla-close DocObj :vlax-false)
;;删除dxf文件
(deletefile dxfFile)
(setq Index (1+ Index))
) ;end repeat
(setvar "acadlspasdoc" HOLDLSP)
(if DocObj
(vlax-release-object DocObj)
)
(if AcadApp
(vlax-release-object AcadApp)
)
) ;end progn
) ;end if
(setq *error* OldError)
(princ)
) ;end defun
;;==============================公用函数==========================
;;;
;;=============获取全路径，即路径后有\=================================
(defun GetFullPath (path)
(if (wcmatch path "*\\")
path
(strcat path "\\")
)
) ;end defun
;;;============================获取文件夹程序=================================
;;;根据Express tools是否安装决定使用哪一个函数
(defun GetFolderNew (InitDir msg / ArxFile Apptitle)
(setq Apptitle "浏览文件夹"
ArxFile "acetutil.arx"
)
(if (findfile ArxFile)
(GetFolder3 Apptitle Msg InitDir)
(getFolder1 msg)
)
) ;end defun
;;;============================获取文件夹程序1=================================
;;来自于明经秋枫
;; 用法：(getFolder1 msg)
;; 例子：(getFolder1 "选择文件夹:")
;; 返回值：字符串，文件夹路径，如果点了cancel, 返回nil
(defun GetFolder1 (msg / WinShell shFolder path catchit)
;|===============================
3. 关于Shell.Application的使用
3.1、创建 Shell 对象
var Shell = new ActiveXObject("Shell.Application");
3.2、使用 Shell 属性及方法
Shell.Application
Shell.Parent
Shell.CascadeWindows()
Shell.TileHorizontally()
Shell.TileVertically()
Shell.ControlPanelItem(sDir) /* 比如：sysdm.cpl */
Shell.EjectPC()
Shell.Explore(vDir)
Shell.Open(vDir)
Shell.FileRun()
Shell.FindComputer()
Shell.FindFiles()
Shell.Help()
Shell.MinimizeAll()
Shell.UndoMinimizeALL()
Shell.RefreshMenu()
Shell.SetTime()
Shell.TrayProperties()
Shell.ShutdownWindows()
Shell.Suspend()
oWindows = Shell.Windows() /* 返回ShellWindows对象 */
fFolder = Shell.NameSpace(vDir) /* 返回所打开的vDir的Folder对象 */
oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [, vRootFolder]) /* 选择文件夹对话框 */
/*示例：
function BrowseFolder()
{
var Message = "清选择文件夹";
var Shell = new ActiveXObject( "Shell.Application" );
var Folder = Shell.BrowseForFolder(0,Message,0x0040,0x11);
if(Folder != null)
{
Folder = Folder.items(); // 返回 FolderItems 对象
Folder = Folder.item(); // 返回 Folderitem 对象
Folder = Folder.Path; // 返回路径
if(Folder.charAt(varFolder.length-1) != "\\"){
Folder = varFolder + "\\";
}
return Folder;
}
}
*/
/*示例：
var Folder = Shell.NameSpace("C:\\"); // 返回 Folder对象
*/
|;
(setq winshell (vlax-create-object "Shell.Application"))
(setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
(setq
catchit (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
(GetFullPath path)
)
) ;end defun
;;;============================获取文件夹程序3=================================
;;;必须安装Express tools后才能使用
(defun GetFolder3 (Apptitle Msg InitDir / ArxFile New_Path catchit)
(setq ArxFile "acetutil.arx")
(if (findfile ArxFile)
(arxload "acetutil.arx" NIL)
(exit)
)
(setq catchit (vl-catch-all-apply
'(lambda ()
(setq New_Path
(strcat
(strcase
(acet-ui-pickdir
Msg
(vl-string-right-trim "\\" InitDir)
Apptitle
)
)
)
)
)
)
)
(if (vl-catch-all-error-p catchit)
nil
(GetFullPath New_Path)
)
) ;end defun
;;============;;注册"MSComDlg.CommonDialog"=============================
(defun Regdlg ()
(vl-registry-write
"HKEY_CLASSES_ROOT\\LICENSES\\4d553650-6abe-11cf-8adb-00aa00c00905"
""
"gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj"
)
) ;end defun
;;=========================vlisp如何打开多重选择文件对话框函数========================
;;来自于明经
;;调用示例
;|(defun C:msfile (/ flags diatl filter initdir)
(setq flags (+ 4 512 4096 32768 524288 1048576)
diatl "选择文件"
filter "图形文件(*.dwg)|*.dwg|所有文件(*.*)|*.*"
initdir (getvar "dwgprefix")
)
(GetMultiFiles flags diatl filter initdir)
) ;end defun
|;
(defun GetMultiFiles (flags diatl filter initdir /
index wincomdlg filem mfile catchit
)
;;首先判断是否已经注册，如果未注册，先注册，此操作需要重新启动CAD
(if (setq wincomdlg (vlax-create-object "MSComDlg.CommonDialog"))
(progn
(vlax-put-property wincomdlg 'CancelError :vlax-true)
(vlax-put-property wincomdlg 'MaxFileSize 32767)
(vlax-put-property
wincomdlg
'Flags
flags
)
(vlax-put-property wincomdlg 'DialogTitle diatl)
(vlax-put-property wincomdlg 'Filter filter)
(vlax-put-property wincomdlg 'InitDir initdir)
(setq
catchit (vl-catch-all-apply ;捕获错误
'(lambda ()
(vlax-invoke-method wincomdlg 'ShowOpen)
(setq filem (vlax-get wincomdlg 'filename))
)
)
)
(vlax-release-object wincomdlg)
(if (vl-catch-all-error-p catchit)
nil ;此时选择的是取消
(progn
(setq Index 1
filem (FSTR->LST filem)
)
(if filem
(if (= 2 (length filem))
(setq
mfile
(list (strcase (strcat (car filem) (cadr filem)) T)
)
)
(repeat (1- (length filem))
(setq mfile (append
mfile
(list (strcase
(strcat (car filem)
"\\"
(nth index filem)
)
T
)
)
)
index (1+ index)
)
) ;end repeat
) ;end if
) ;end if
) ;end progn
) ;end if
)
(progn
(alert "当前系统无MSComDlg.CommonDialog对象！")
(Regdlg)
)
)
mfile ;返回值
) ;end defun
;;============将输入的数据转换为字符串列表===================
(defun FSTR->LST (FM / N ff)
(setq FF NIL)
(IF (VL-STRING-POSITION (ASCII "\000") FM)
(PROGN
(WHILE (VL-STRING-POSITION (ASCII "\000") FM)
(SETQ N (VL-STRING-POSITION (ASCII "\000") FM))
(SETQ FF (APPEND FF (LIST (SUBSTR FM 1 N))))
(SETQ FM (SUBSTR FM (+ N 2) (- (STRLEN FM) N 1)))
)
(SETQ FF (APPEND FF (LIST FM)))
)
(PROGN
(SETQ FF (VL-FILENAME-DIRECTORY FM))
(SETQ FF (LIST FF (VL-STRING-SUBST "" FF FM)))
)
)
) ;end defun
;;=============获取指定文件夹(不包括子文件夹)下所有满足扩展名的文件===========
;;返回列表文件表元素全为小写
(defun GetAllSpecFilesInFolder (dir filter)
(mapcar
(function
(lambda (file)
(strcase (strcat (getfullpath dir) file) T)
)
)
(vl-directory-files dir filter 1)
)
) ;end defun
;;=============获取指定文件夹(包括子文件夹)下所有满足扩展名的文件===========
(defun GetAllSpecFilesInFolders (dir filter / filenames)
(setq filenames (mapcar
(function
(lambda (file)
(strcase (strcat (getfullpath dir) file) T)
;;递归出口
)
)
(vl-directory-files dir filter 1)
)
)
(mapcar
(function
(lambda (subdir)
;; 此处递归
(setq filenames (append filenames
(GetAllSpecFilesInFolders
(strcat (getfullpath dir) subdir)
filter
)
)
)
)
)
(vl-remove-if
(function (lambda (subdir)
(member subdir '("." ".."))
)
)
(vl-directory-files dir nil -1)
)
)
filenames
) ;end defun
;;;定义VB中对话框msgbox几个输入常数:全局变量
;; MsgBox(prompt[, buttons][, title][, helpfile, context])
;; Buttons:
;; vbOKOnly 0 Display OK button only.
;; vbOKCancel 1 Display OK and Cancel buttons.
;; vbAbortRetryIgnore 2 Display Abort, Retry, and Ignore buttons.
;; vbYesNoCancel 3 Display Yes, No, and Cancel buttons.
;; vbYesNo 4 Display Yes and No buttons.
;; vbRetryCancel 5 Display Retry and Cancel buttons.
;; vbCritical 16 Display Critical Message icon.
;; vbQuestion 32 Display Warning Query icon.
;; vbExclamation 48 Display Warning Message icon.
;; vbInformation 64 Display Information Message icon.
;; vbDefaultButton1 0 First button is default.
;; vbDefaultButton2 256 Second button is default.
;; vbDefaultButton3 512 Third button is default.
;; vbDefaultButton4 768 Fourth button is default.
;; vbApplicationModal 0 Application modal; the user must respond to the message box before continuing work in the current application.
;; vbSystemModal 4096 System modal; all applications are suspended until the user responds to the message box.
(setq vbOKOnly 0)
(setq vbOKCancel 1)
(setq vbAbortRetryIgnore 2)
(setq vbYesNoCancel 3)
(setq vbYesNo 4)
(setq vbRetryCancel 5)
(setq vbCritical 16
vbQuestion 32
)
(setq vbExclamation 48
vbInformation 64
vbDefaultButton1 0
vbDefaultButton2 256
vbDefaultButton3 512
vbDefaultButton4 768
vbApplicationModal 0
vbSystemModal 4096
)
;;返回值
;;1 OK button
;;2 Cancel button
;;3 Abort button
;;4 Retry button
;;5 Ignore button
;;6 Yes button
;;7 No button
(setq rs_OK 1
rs_Cancel 2
rs_Abort 3
rs_Retry 4
rs_Ignore 5
rs_Yes 6
rs_No 7
)
;; A cute little utility to invoke a VBA message box and return a value to AutoLisp.
;; Requires AutoCAD 2000 (R15) or higher.
;; The buttons are a Boolean value representing a logical sum of
;; the following values:
;;--------------------------------------------------------
;; MsgBox(prompt[, buttons][, title][, helpfile, context])
;; Buttons:
;; vbOKOnly 0 Display OK button only.
;; vbOKCancel 1 Display OK and Cancel buttons.
;; vbAbortRetryIgnore 2 Display Abort, Retry, and Ignore buttons.
;; vbYesNoCancel 3 Display Yes, No, and Cancel buttons.
;; vbYesNo 4 Display Yes and No buttons.
;; vbRetryCancel 5 Display Retry and Cancel buttons.
;; vbCritical 16 Display Critical Message icon.
;; vbQuestion 32 Display Warning Query icon.
;; vbExclamation 48 Display Warning Message icon.
;; vbInformation 64 Display Information Message icon.
;; vbDefaultButton1 0 First button is default.
;; vbDefaultButton2 256 Second button is default.
;; vbDefaultButton3 512 Third button is default.
;; vbDefaultButton4 768 Fourth button is default.
;; vbApplicationModal 0 Application modal; the user must respond to the message box before continuing work in the current application.
;; vbSystemModal 4096 System modal; all applications are suspended until the user responds to the message box.
;;test：(MsgBox "This is a test!" vbOKCancel "Iceberg CAD Tools")
(defun MsgBox (Title Buttons Message / useri1 value)
(vl-load-com)
(or *acad* (setq *acad* (vlax-get-acad-object)))
(setq useri1 (getvar "useri1"))
(acad-push-dbmod)
(vla-eval
*acad*
(strcat
"ThisDrawing.SetVariable \"USERI1\","
"MsgBox (\""
Message
"\","
(itoa Buttons)
",\""
Title
"\")"
)
)
(setq value (getvar "useri1"))
(setvar "useri1" useri1)
(acad-pop-dbmod)
value
) ;end defun
;;=========获取ObjectDBX版本字符串============
(defun GetObjectDBXVer (/ VERSION)
(if (>= (setq VERSION (atoi (getvar "acadver"))) 16)
(strcat "ObjectDBX.AxDbDocument." (itoa VERSION))
nil
) ;end if
) ;end defun
;;;===========从图元表中提取dxf组码值函数组码值函数
(defun dxf (Item dxfList /) (cdr (assoc Item dxfList))) ;defun
;;=================删除文件函数===================
;; 能删除所有文件，不管只读、隐藏与否，都能删除
;; vl-file-delete不能删除只读文件
;;Scripting.FileSystemObject格式
;;fso.DeleteFile ( filespec[, force] )
;;参数
;; fso 必选项, 应为 FileSystemObject 的名称。
;; filespec 必选项, 要删除的文件的名称,filespec 可以在最后的路径成分中包含通配字符。
;; force 可选项, Boolean 值，如果要删除设置了只读属性的文件，则为 true ；如果不删除则为 false （默认）。
;; Arguments [Typ]:
;; Fil = FileName, "C:\\test\\Autoexec.bat" [STR]
;; Notes:
;; - Requires ScrRun.dll.
;; USAGE: (DelFile "C:\\test\\*.*")
;; USAGE: (DelFile "C:\\test\\Autoexec.bat")
(defun DeleteFile (FIL / FILSYS FILDIR SS ENT)
(setq FILSYS (vlax-create-object "Scripting.FileSystemObject"))
(setq FILDIR (vl-filename-directory FIL))
(setq
SS (vl-directory-files
FILDIR
(strcat (vl-filename-base FIL) (vl-filename-extension FIL))
1
)
)
(foreach ENT SS
(vlax-invoke
FILSYS
"deletefile"
(strcat FILDIR "\\" ENT)
:vlax-false
)
)
(vlax-release-object FILSYS)
(princ)
)
;end defun
(defun makelist (str pat / i j n lst)
;;生成表记录函数：把字符串变为表
(cond
((/= (type str) (type pat) 'STR))
((= str pat) '(""))
(T
(setq i 0
n (strlen pat)
)
(while (setq j (vl-string-search pat str i))
(setq lst (cons (substr str (1+ i) (- j i)) lst)
i (+ j n)
)
)
(reverse (cons (substr str (1+ i)) lst))
)
)
)
(defun GetObjectDBXVer (/ VERSION)
(if (>= (setq VERSION (atoi (getvar "acadver"))) 16)
(strcat "ObjectDBX.AxDbDocument." (itoa VERSION))
nil
) ;end if
) ;end defun
;;;===========从图元表中提取dxf组码值函数组码值函数
(defun dxf (Item dxfList /) (cdr (assoc Item dxfList))) ;defun
;;=================删除文件函数===================
;; 能删除所有文件，不管只读、隐藏与否，都能删除
;; vl-file-delete不能删除只读文件
;;Scripting.FileSystemObject格式
;;fso.DeleteFile ( filespec[, force] )
;;参数
;; fso 必选项, 应为 FileSystemObject 的名称。
;; filespec 必选项, 要删除的文件的名称,filespec 可以在最后的路径成分中包含通配字符。
;; force 可选项, Boolean 值，如果要删除设置了只读属性的文件，则为 true ；如果不删除则为 false （默认）。
;; Arguments [Typ]:
;; Fil = FileName, "C:\\test\\Autoexec.bat" [STR]
;; Notes:
;; - Requires ScrRun.dll.
;; USAGE: (DelFile "C:\\test\\*.*")
;; USAGE: (DelFile "C:\\test\\Autoexec.bat")
(defun DeleteFile (FIL / FILSYS FILDIR SS ENT)
(setq FILSYS (vlax-create-object "Scripting.FileSystemObject"))
(setq FILDIR (vl-filename-directory FIL))
(setq
SS (vl-directory-files
FILDIR
(strcat (vl-filename-base FIL) (vl-filename-extension FIL))
1
)
)
(foreach ENT SS
(vlax-invoke
FILSYS
"deletefile"
(strcat FILDIR "\\" ENT)
:vlax-false
)
)
(vlax-release-object FILSYS)
(princ)
) ;end defun
(defun AddSeprate (DataList delimiter / i len dealdata TempData)
;;添加分隔符函数
(setq i 1
len (length DataList)
)
(if len
(progn
(setq dealdata (nth 0 DataList))
(if (numberp dealdata)
(setq dealdata (rtos dealdata 2))
)
(repeat (1- len)
(setq TempData (nth i DataList))
(if (numberp TempData)
(setq TempData (rtos TempData 2))
)
(setq dealdata (strcat dealdata delimiter TempData))
(setq i (1+ i))
)
)
)
(setq DataList dealdata)
)

;;DWG文件版本批量转换程序 命令 DwgConverter 
;;DWG文件去除教育版标记   命令 DelEduLog 
;;程序源码来自明经CAD iceberg2509 于2011.10.18 
;;xiaoyingzi修改成支持autocad2004~2010 
;;=================DWG文件版本批量转换程序===================== 
(defun C:Dwgbbzh (/     pass         DwgVer     DwgType 
           dcl_id     pop_ver     OldError     FileExt 
           IsDxfExt     Initdir     HOLDLSP     AcadApp 
           DocObj     Index       DwgName     BaseName 
           filepath     DxfFile     NewFile     dwgfileLst 
           lst_DwgFile tog_subfolder 
          ) 
          ;| 
object.SaveAsType 
  object  PreferencesOpenSave 
  The object this property applies to. 
  SaveAsType 
  acSaveAsType enum; read-write 
  acR14_dwg     AutoCAD R14 DWG (*.dwg) 
  ac2000_dwg     AutoCAD 2000 DWG (*.dwg) 
  ac2000_dxf    AutoCAD 2000 DXF (*.dxf) 
  ac2000_Template    AutoCAD 2000 Drawing Template File (*.dwt) 
  ac2004_dwg     AutoCAD 2004 DWG (*.dwg) 
  ac2004_dxf     AutoCAD 2004 DXF (*.dxf) 
  ac2004_Template   AutoCAD 2004 Drawing Template File (*.dwt) 
  ac2007_dwg    AutoCAD 2007 DWG (*.dwg) 
  ac2007_dxf     AutoCAD 2007 DXF (*.dxf) 
  ac2007_Template   AutoCAD 2007 Drawing Template File (*.dwt) 
  ac2010_dwg      AutoCAD 2010 DWG (*.dwg) 
  ac2010_dxf       AutoCAD 2010 DXF (*.dxf) 
  ac2010_Template    AutoCAD 2010 Drawing Template File (*.dwt) 
  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. 
  AcUnknown    Read-only. The drawing type is unknown or invalid. 
Remarks 
The initial value for this property is ac2010_dwg. The following values are obsolete: acR13_DWG, acR13_DXF, acR14_DWG, and acR14_DXF. 
 |; 
  ;;Sub DxfOut(ByVal FileName As String, Optional ByVal precision As Variant, Optional ByVal SaveThumbnailImage As Variant) 
  ;;Sub SaveAs(ByVal FileName As String, Optional ByVal vSecurityParams As Variant) 
  ;;Sub Open  (ByVal FileName As String, Optional ByVal Password As Variant) 
  ;;============加载dwg文件到列表============== 
  (defun LoadDwgFileLst  (fileslst / HasOpenFiles) 
    (if  fileslst 
      (progn 
  (if dwgfileLst 
    (progn 
      (mapcar '(lambda (tmpfile) 
           (setq dwgfileLst 
            (vl-remove (strcase tmpfile T) dwgfileLst) 
           ) 
         ) 
        fileslst 
      ) 
      (setq dwgfileLst (append dwgfileLst fileslst)) 
    ) 
    (setq dwgfileLst fileslst) 
  )        ;end if 
  ;;检测文件是否打开 
  (setq HasOpenFiles (vl-remove-if 'VL-FILE-SYSTIME dwgfileLst) 
        dwgfileLst   (vl-remove-if-not 'VL-FILE-SYSTIME dwgfileLst) 
  ) 
  (if dwgfileLst 
    (setq dwgfileLst (vl-sort dwgfileLst '<)) 
  ) 
  (if HasOpenFiles 
    (alert (strcat "以下文件已经被打开，无法添加到列表：\n" 
       (AddSeprate HasOpenFiles "\n") 
     ) 
    ) 
  ) 
  (start_list "lst_DwgFile") 
  (mapcar 'add_list dwgfileLst) 
  (end_list) 
      ) 
    )          ;end if 
    (OkBtnIsEnabled) 
  )          ;end defun 
 
  ;;============获取指定文件夹下的所有dwg文件================= 
  (defun AddDwgFilesInFolder (/ filter dwgPath dwgfiles) 
    (setq filter  "*.dwg" 
    dwgPath (GetFolderNew Initdir "选择DWG文件夹") 
    ) 
    (if  dwgPath 
      (progn 
  (setq Initdir dwgPath) 
  (if (= "0" tog_subfolder) 
    (setq dwgfiles (GetAllSpecFilesInFolder dwgPath filter)) 
    (setq dwgfiles (GetAllSpecFilesInFolders dwgPath filter)) 
  ) 
  (LoadDwgFileLst dwgfiles) 
      ) 
    ) 
  )          ;end defun 
 
  ;;===============获取选中的dwg文件===================== 
  (defun AddDwgFiles (/ flags diatl filter dwgfiles) 
    (setq flags   (+ 4 512 4096 32768 524288 1048576) 
    diatl   "选择文件" 
    filter "图形(*.dwg)|*.dwg" 
    ) 
    (setq dwgfiles (GetMultiFiles flags diatl filter Initdir)) 
    (if  dwgfiles 
      (progn 
  (setq Initdir (vl-filename-directory (car dwgfiles))) 
  (LoadDwgFileLst dwgfiles) 
      ) 
    ) 
  )          ;end defun 
 
  ;;=============移除按钮状态函数======================= 
  (defun DelBtnIsEnabled () 
    (if  lst_DwgFile 
      (mode_tile "but_del" 0) 
      (mode_tile "but_del" 1) 
    ) 
  )          ;end defun 
 
  ;;=============确认按钮是否激活函数======================= 
  (defun OkBtnIsEnabled  () 
    (if  (null dwgfileLst) 
      (mode_tile "but_OK" 1) 
      (mode_tile "but_OK" 0) 
    ) 
  ) 
 
  ;;==============移除选定文件函数======================= 
  (defun RemoveDwgFiles  (/ IndexLst RemoveDwgLst) 
    (if  lst_DwgFile 
      (progn 
  (setq IndexLst     (makelist lst_DwgFile " ") 
        RemoveDwgLst (mapcar '(lambda (index) 
              (nth (atoi index) dwgfileLst) 
            ) 
           IndexLst 
         ) 
  ) 
  ;;移除选定文件 
  (mapcar  '(lambda (tmpfile) 
       (setq dwgfileLst 
        (vl-remove (strcase tmpfile T) dwgfileLst) 
       ) 
     ) 
    RemoveDwgLst 
  ) 
  (start_list "lst_DwgFile") 
  (mapcar 'add_list dwgfileLst) 
  (end_list) 
  (setq lst_DwgFile nil) 
      ) 
    )          ;end if 
    (DelBtnIsEnabled) 
    (OkBtnIsEnabled) 
  )          ;end defun 
 
  ;;====================对话框驱动函数========================== 
  (defun ConvDwgLst ( / fname fn dclid lin return# ) 
      (setq fname (vl-filename-mktemp nil nil ".dcl")) 
  (setq fn (open fname "w")) 
(write-line "" fn) 
(write-line "dcl_settings : default_dcl_settings { audit_level = 3; }" fn) 
(write-line "" fn) 
(write-line "" fn) 
(write-line "BatConVer : dialog {" fn) 
(write-line "    label = \"批量转换DWG文件版本\";" fn) 
(write-line "    : row {" fn) 
(write-line "        : column {" fn) 
(write-line "           : boxed_row {" fn) 
(write-line "               label = \"转换版本\";" fn) 
(write-line "               : popup_list {" fn) 
(write-line "                  key = \"pop_ver\";" fn) 
(write-line "                  //width=36;" fn) 
(write-line "               }" fn) 
(write-line "           }" fn) 
(write-line "           : boxed_row {" fn) 
(write-line "              label=\"DWG文件列表\";" fn) 
(write-line "              : list_box {                 " fn) 
(write-line "                 key=\"lst_DwgFile\";" fn) 
(write-line "                 width=70;" fn) 
(write-line "                 height=35;" fn) 
(write-line "                 allow_accept=true;" fn) 
(write-line "                multiple_select=true;" fn) 
(write-line "              }" fn) 
(write-line "          }" fn) 
(write-line "        }" fn) 
(write-line "        : column {" fn) 
(write-line "            spacer;" fn) 
(write-line "            spacer;" fn) 
(write-line "            : button {" fn) 
(write-line "                label = \"添加文件夹...\";" fn) 
(write-line "                key = \"but_addfolder\";" fn) 
(write-line "                fixed_width = true;" fn) 
(write-line "            }" fn) 
(write-line "            : toggle {" fn) 
(write-line "                label = \"包括子文件夹\";" fn) 
(write-line "                key = \"tog_subfolder\";" fn) 
(write-line "            }" fn) 
(write-line "            : button {" fn) 
(write-line "                label = \"添加文件...\";" fn) 
(write-line "                key = \"but_addfile\";" fn) 
(write-line "            }" fn) 
(write-line "            : button {" fn) 
(write-line "                label = \"删除...\";" fn) 
(write-line "                key = \"but_del\";" fn) 
(write-line "                is_enabled = false;" fn) 
(write-line "            }" fn) 
(write-line "            : button {" fn) 
(write-line "                label = \"确定(&A)\";" fn) 
(write-line "                key = \"but_OK\";" fn) 
(write-line "                is_enabled = false;" fn) 
(write-line "                //is_default = true;" fn) 
(write-line "            }" fn) 
(write-line "            : button {" fn) 
(write-line "                label = \"取消(&C)\";" fn) 
(write-line "                key = \"but_Cancel\";" fn) 
(write-line "                is_cancel = true;" fn) 
(write-line "            }" fn) 
(write-line "            spacer;" fn) 
(write-line "            spacer;" fn) 
(write-line "            spacer;" fn) 
(write-line "       }" fn) 
(write-line "    }" fn) 
(write-line "}" fn) 
(write-line "" fn) 
  (close fn) 
  (setq fn (open fname "r")) 
  (setq dclid (load_dialog fname)) 
  (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")))) 
  (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid) 
    ;;子文件夹 
    (start_list "pop_ver") 
    (mapcar 'add_list (mapcar '(lambda (x) (cadr x)) DwgType)) 
    (end_list) 
    (if  (not pop_ver) 
      (setq pop_ver "0") 
    ) 
    (set_tile "pop_ver" pop_ver) 
 
    ;;子文件夹 
    (if  (not tog_subfolder) 
      (setq tog_subfolder "0") 
    ) 
    (set_tile "tog_subfolder" tog_subfolder) 
 
    (action_tile "pop_ver" "(setq pop_ver $value)") 
    (action_tile "but_addfolder" "(AddDwgFilesInFolder)") 
    (action_tile "but_addfile" "(AddDwgFiles)") 
    (action_tile "but_del" "(RemoveDwgFiles)") 
    (action_tile "tog_subfolder" "(setq tog_subfolder $value)") 
    (action_tile 
      "lst_DwgFile" 
      "(setq lst_DwgFile $value)(DelBtnIsEnabled)" 
    ) 
    (action_tile "but_OK" "(setq pass T)(done_dialog 1)") 
    (action_tile "but_Cancel" "(done_dialog 0)") 
      (setq return# (start_dialog)) 
  (princ return#) 
  (unload_dialog dclid) 
  (close fn) 
  (vl-file-delete fname) 
  (princ) 
)        ;end defun 
 
  ;;===========定义容错函数=============== 
  (defun MyError (msg) 
    (if  (or (= msg "Function cancelled") 
      (= msg "quit / exit abort") 
      (= msg "函数被取消") 
      (= msg "函数已取消") 
  ) 
      (princ) 
      (princ (strcat "\n 错误:" msg "\n")) 
    ) 
    (setvar "acadlspasdoc" HOLDLSP) 
    (princ) 
  ) 
 
  ;;=======================主函数=========== 
  (setq  OldError *error* 
  *error*   MyError 
  ) 
  (if (not MsgBox) 
    (load "MsgBox") 
  ) 
  (cond 
    ((< (atof (getvar "acadver")) 16)  ;检查版本 
     (MsgBox "版本检查" 
       (+ vbOKOnly vbInformation) 
       "此程序只能运行在AutoCAD 2004或更高版本!" 
     ) 
     (exit) 
    ) 
    ((= 1 (getvar "dwgtitled"))    ;检查使用文件环境 
     (MsgBox "使用环境检查" 
       (+ vbOKOnly vbInformation) 
       "该程序只能在未保存的文件中运行！" 
     ) 
     (exit) 
    ) 
    ((not (setq dcl_id (load_dialog "dwgconverter"))) 
     (MsgBox "无法加载对话框文件！" 
       (+ vbOKOnly vbInformation) 
       "数据检查" 
     ) 
     (exit) 
    ) 
  )          ;end cond 
 
  (setq  Initdir  (getvar "dwgprefix") 
  pass  nil 
  ) 
  (cond 
    ((or (= (atof (getvar "acadver")) 16.0) (= (atof (getvar "acadver")) 16.1) (= (atof (getvar "acadver")) 16.2)) 
     (setq DwgType (list (list 0 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg) 
             (list 1 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf) 
             (list 2 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg) 
             (list 3 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf) 
       ) 
     ) 
    ) 
    ((or (= (atof (getvar "acadver")) 17.0) (= (atof (getvar "acadver")) 17.1) (= (atof (getvar "acadver")) 17.2)) 
     (setq DwgType (list (list 0 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg) 
             (list 1 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf) 
             (list 2 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg) 
             (list 3 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf) 
             (list 4 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg) 
             (list 5 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf) 
             (list 6 "AutoCAD R14 DWG (*.dxf)" acR14_dxg) 
       ) 
     ) 
    ) 
    ((= (atof (getvar "acadver")) 18.0) 
     (setq DwgType (list (list 0 "AutoCAD 2010 DWG (*.dwg)" ac2010_dwg) 
             (list 1 "AutoCAD 2010 DXF (*.dxf)" ac2010_dxf) 
             (list 2 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg) 
             (list 3 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf) 
             (list 4 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg) 
             (list 5 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf) 
             (list 6 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg) 
             (list 7 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf) 
             (list 8 "AutoCAD R14 DWG (*.dxf)" acR14_dxg) 
       )       
     ) 
    ) 
    ((= (atof (getvar "acadver")) 18.1) 
     (setq DwgType (list (list 0 "AutoCAD 2010 DWG (*.dwg)" ac2010_dwg) 
             (list 1 "AutoCAD 2010 DXF (*.dxf)" ac2010_dxf) 
             (list 2 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg) 
             (list 3 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf) 
             (list 4 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg) 
             (list 5 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf) 
             (list 6 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg) 
             (list 7 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf) 
             (list 8 "AutoCAD R14 DWG (*.dxf)" acR14_dxg) 
       )       
     ) 
    ) 
    ((= (atof (getvar "acadver")) 18.2) 
     (setq DwgType (list (list 0 "AutoCAD 2010 DWG (*.dwg)" ac2010_dwg) 
             (list 1 "AutoCAD 2010 DXF (*.dxf)" ac2010_dxf) 
             (list 2 "AutoCAD 2007 DWG (*.dwg)" ac2007_dwg) 
             (list 3 "AutoCAD 2007 DXF (*.dxf)" ac2007_dxf) 
             (list 4 "AutoCAD 2004 DWG (*.dwg)" ac2004_dwg) 
             (list 5 "AutoCAD 2004 DXF (*.dxf)" ac2004_dxf) 
             (list 6 "AutoCAD 2000 DWG (*.dwg)" ac2000_dwg) 
             (list 7 "AutoCAD 2000 DXF (*.dxf)" ac2000_dxf) 
             (list 8 "AutoCAD R14 DWG (*.dxf)" acR14_dxg) 
       )      ;这里为什么用list而不用 '，是因为用'后，ac2012_dwg等就不会求值了，导致后续程序取值错误 
     ) 
    ) 
  ) 
  ;;打开对话框控制函数 
  (ConvDwgLst) 
 
  (if (and pass (not (null dwgfileLst))) 
    (progn 
      (setq Index   0 
      HOLDLSP (getvar "ACADLSPASDOC") 
      AcadApp (vlax-get-acad-object) 
      pop_ver (atoi pop_ver) 
      DwgVer  (last (dxf pop_ver DwgType)) 
      ) 
      (if (or (= pop_ver 1) (= pop_ver 3) (= pop_ver 5) (= pop_ver 7) (= pop_ver 9)) 
  (setq IsDxfExt T 
        FileExt ".dxf" 
  ) 
  (setq IsDxfExt nil 
        FileExt ".dwg" 
  ) 
      ) 
      ;;(setvar "acadlspasdoc" 0) 
      (repeat (length dwgfileLst) 
  (setq DwgName  (nth Index dwgfileLst) 
        BaseName (vl-filename-base DwgName) 
        filepath (vl-filename-directory DwgName) 
        DxfFile  (strcat (getfullpath filepath) 
             BaseName 
             ".dxf" 
           ) 
        NewFile  (vl-filename-mktemp BaseName filepath FileExt) 
        DocObj   (vla-open (vla-get-documents AcadApp) DwgName) 
  ) 
  ;;将原dwg文件存为指定版本的 
  (vla-saveas DocObj NewFile DwgVer) 
  (vla-close DocObj :vlax-false) 
 
  (if IsDxfExt 
    (progn 
      ;;如果新文件后缀是dxf，就把dxf改为跟dwg同名文件 
      (if  (findfile DxfFile) 
        (deletefile DxfFile) 
      ) 
      (vl-file-rename NewFile DxfFile) 
    ) 
    (progn 
      ;;如果新文件后缀是dwg，就删除原dwg文件 
      (deletefile DwgName) 
      ;;再把新保存的文件名改为原dwg文件名 
      (vl-file-rename NewFile DwgName) 
    ) 
  ) 
  (setq Index (1+ Index)) 
      )          ;end repeat 
 
      (setvar "acadlspasdoc" HOLDLSP) 
      (if DocObj 
  (vlax-release-object DocObj) 
      ) 
      (if AcadApp 
  (vlax-release-object AcadApp) 
      ) 
    )          ;end progn 
  )          ;end if 
 
  (setq *error* OldError) 
  (princ) 
 
)          ;end defun 
 
;;=================dwg转dxf文件函数================ 
(defun Dwg2Dxf (DwgName dxfName / AcadApp dbxDoc) 
  (setq  AcadApp  (vlax-get-acad-object) 
  dbxDoc  (vla-GetInterfaceObject 
      AcadApp 
      (GetObjectDBXVer) 
    ) 
  ) 
  (vla-open dbxDoc DwgName) 
  (vlax-invoke dbxDoc "dxfout" dxfName) 
  (if dbxDoc 
    (vlax-release-object dbxDoc) 
  )          ;关闭文档 
  (if AcadApp 
    (vlax-release-object AcadApp) 
  ) 
)          ;end defun 
 
;;========================去除教育版标记================================ 
(defun C:Deljyb (/    pass      dcl_id  OldError 
        DxfExt  Initdir      BackUp  HOLDLSP 
        AcadApp  DocObj      Index  DwgName 
        BaseName  filepath    dxfFile  BackupFile 
        dwgfileLst  lst_DwgFile tog_subfolder 
       ) 
  ;;============加载dwg文件到列表============== 
  (defun LoadDwgFileLst  (fileslst / HasOpenFiles) 
    (if  fileslst 
      (progn 
  (if dwgfileLst 
    (progn 
      (mapcar '(lambda (tmpfile) 
           (setq dwgfileLst 
            (vl-remove (strcase tmpfile T) dwgfileLst) 
           ) 
         ) 
        fileslst 
      ) 
      (setq dwgfileLst (append dwgfileLst fileslst)) 
    ) 
    (setq dwgfileLst fileslst) 
  )        ;end if 
  ;;检测文件是否打开 
  (setq HasOpenFiles (vl-remove-if 'VL-FILE-SYSTIME dwgfileLst) 
        dwgfileLst   (vl-remove-if-not 'VL-FILE-SYSTIME dwgfileLst) 
  ) 
  (if dwgfileLst 
    (setq dwgfileLst (vl-sort dwgfileLst '<)) 
  ) 
  (if HasOpenFiles 
    (alert (strcat "以下文件已经被打开，无法添加到列表：\n" 
       (AddSeprate HasOpenFiles "\n") 
     ) 
    ) 
  ) 
  (start_list "lst_DwgFile") 
  (mapcar 'add_list dwgfileLst) 
  (end_list) 
      ) 
    )          ;end if 
    (OkBtnIsEnabled) 
  )          ;end defun 
 
  ;;============获取指定文件夹下的所有dwg文件================= 
  (defun AddDwgFilesInFolder (/ filter dwgPath dwgfiles) 
    (setq filter  "*.dwg" 
    dwgPath (GetFolderNew Initdir "选择DWG文件夹") 
    ) 
    (if  dwgPath 
      (progn 
  (setq Initdir dwgPath) 
  (if (= "0" tog_subfolder) 
    (setq dwgfiles (GetAllSpecFilesInFolder dwgPath filter)) 
    (setq dwgfiles (GetAllSpecFilesInFolders dwgPath filter)) 
  ) 
  (LoadDwgFileLst dwgfiles) 
      ) 
    ) 
  )          ;end defun 
 
  ;;===============获取选中的dwg文件===================== 
  (defun AddDwgFiles (/ flags diatl filter dwgfiles) 
    (setq flags   (+ 4 512 4096 32768 524288 1048576) 
    diatl   "选择文件" 
    filter "图形(*.dwg)|*.dwg" 
    ) 
    (setq dwgfiles (GetMultiFiles flags diatl filter Initdir)) 
    (if  dwgfiles 
      (progn 
  (setq Initdir (vl-filename-directory (car dwgfiles))) 
  (LoadDwgFileLst dwgfiles) 
      ) 
    ) 
  )          ;end defun 
 
  ;;=============移除按钮状态函数======================= 
  (defun DelBtnIsEnabled () 
    (if  lst_DwgFile 
      (mode_tile "but_del" 0) 
      (mode_tile "but_del" 1) 
    ) 
  )          ;end defun 
 
  ;;=============确认按钮是否激活函数======================= 
  (defun OkBtnIsEnabled  () 
    (if  (null dwgfileLst) 
      (mode_tile "but_OK" 1) 
      (mode_tile "but_OK" 0) 
    ) 
  ) 
 
  ;;==============移除选定文件函数======================= 
  (defun RemoveDwgFiles  (/ IndexLst RemoveDwgLst) 
    (if  lst_DwgFile 
      (progn 
  (setq IndexLst     (makelist lst_DwgFile " ") 
        RemoveDwgLst (mapcar '(lambda (index) 
              (nth (atoi index) dwgfileLst) 
            ) 
           IndexLst 
         ) 
  ) 
  ;;移除选定文件 
  (mapcar  '(lambda (tmpfile) 
       (setq dwgfileLst 
        (vl-remove (strcase tmpfile T) dwgfileLst) 
       ) 
     ) 
    RemoveDwgLst 
  ) 
  (start_list "lst_DwgFile") 
  (mapcar 'add_list dwgfileLst) 
  (end_list) 
  (setq lst_DwgFile nil) 
      ) 
    )          ;end if 
    (DelBtnIsEnabled) 
    (OkBtnIsEnabled) 
  )          ;end defun 
 
  ;;====================对话框驱动函数========================== 
  (defun GetEduDwgLst ( / fname fn dclid lin return# ) 
  (setq fname (vl-filename-mktemp nil nil ".dcl")) 
  (setq fn (open fname "w")) 
(write-line "" fn) 
(write-line "dcl_settings : default_dcl_settings { audit_level = 3; }" fn) 
(write-line "" fn)(write-line "BatDelEdu : dialog {" fn) 
(write-line "    label = \"批量删除教育版标记\";" fn) 
(write-line "    : row {" fn) 
(write-line "        : boxed_column {" fn) 
(write-line "           label=\"DWG文件列表\";" fn) 
(write-line "           : list_box {" fn) 
(write-line "              //label=\"DWG文件列表\";" fn) 
(write-line "              key=\"lst_DwgFile\";" fn) 
(write-line "              width=70;" fn) 
(write-line "              height=35;" fn) 
(write-line "              allow_accept=true;" fn) 
(write-line "              multiple_select=true;" fn) 
(write-line "           }" fn) 
(write-line "        }        " fn) 
(write-line "        : column {" fn) 
(write-line "            spacer;" fn) 
(write-line "            spacer;" fn) 
(write-line "            : button {" fn) 
(write-line "                label = \"添加文件夹...\";" fn) 
(write-line "                key = \"but_addfolder\";" fn) 
(write-line "                fixed_width = true;" fn) 
(write-line "            }" fn) 
(write-line "            : toggle {" fn) 
(write-line "                label = \"包括子文件夹\";" fn) 
(write-line "                key = \"tog_subfolder\";" fn) 
(write-line "            }" fn) 
(write-line "            : button {" fn) 
(write-line "                label = \"添加文件...\";" fn) 
(write-line "                key = \"but_addfile\";" fn) 
(write-line "            }" fn) 
(write-line "            : button {" fn) 
(write-line "                label = \"删除...\";" fn) 
(write-line "                key = \"but_del\";" fn) 
(write-line "                is_enabled = false;" fn) 
(write-line "            }" fn) 
(write-line "            : button {" fn) 
(write-line "                label = \"确定(&A)\";" fn) 
(write-line "                key = \"but_OK\";" fn) 
(write-line "                is_enabled = false;" fn) 
(write-line "                //is_default = true;" fn) 
(write-line "            }" fn) 
(write-line "            : button {" fn) 
(write-line "                label = \"取消(&C)\";" fn) 
(write-line "                key = \"but_Cancel\";" fn) 
(write-line "                is_cancel = true;" fn) 
(write-line "            }" fn) 
(write-line "            spacer;" fn) 
(write-line "            spacer;" fn) 
(write-line "            spacer;" fn) 
(write-line "       }" fn) 
(write-line "    }" fn) 
(write-line "}" fn) 
(write-line "" fn) 
 
(close fn) 
  (setq fn (open fname "r")) 
  (setq dclid (load_dialog fname)) 
  (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")))) 
  (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid) 
    ;;子文件夹 
    (if  (not tog_subfolder) 
      (setq tog_subfolder "0") 
    ) 
    (set_tile "tog_subfolder" tog_subfolder) 
 
    (action_tile "but_addfolder" "(AddDwgFilesInFolder)") 
    (action_tile "but_addfile" "(AddDwgFiles)") 
    (action_tile "but_del" "(RemoveDwgFiles)") 
    (action_tile "tog_subfolder" "(setq tog_subfolder $value)") 
    (action_tile 
      "lst_DwgFile" 
      "(setq lst_DwgFile $value)(DelBtnIsEnabled)" 
    ) 
    (action_tile "but_OK" "(setq pass T)(done_dialog 1)") 
    (action_tile "but_Cancel" "(done_dialog 0)") 
   (setq return# (start_dialog)) 
  (princ return#) 
  (unload_dialog dclid) 
  (close fn) 
  (vl-file-delete fname) 
  (princ) 
)      ;end defun 
 
  ;;===========定义容错函数=============== 
  (defun MyError (msg) 
    (if  (or (= msg "Function cancelled") 
      (= msg "quit / exit abort") 
      (= msg "函数被取消") 
      (= msg "函数已取消") 
  ) 
      (princ) 
      (princ (strcat "\n 错误:" msg "\n")) 
    ) 
    (setvar "acadlspasdoc" HOLDLSP) 
    (princ) 
  ) 
 
  ;;=======================主函数=========== 
  (setq  OldError *error* 
  *error*   MyError 
  ) 
  (if (not MsgBox) 
    (load "MsgBox") 
  ) 
  (cond 
    ((< (atof (getvar "acadver")) 16)  ;检查版本 
     (MsgBox "版本检查" 
       (+ vbOKOnly vbInformation) 
       "此程序只能运行在AutoCAD 2004或更高版本!" 
     ) 
     (exit) 
    ) 
    ((= 1 (getvar "dwgtitled"))    ;检查使用文件环境 
     (MsgBox "使用环境检查" 
       (+ vbOKOnly vbInformation) 
       "该程序只能在未保存的文件中运行！" 
     ) 
     (exit) 
    ) 
    ((not (setq dcl_id (load_dialog "dwgconverter"))) 
     (MsgBox "无法加载对话框文件！" 
       (+ vbOKOnly vbInformation) 
       "数据检查" 
     ) 
     (exit) 
    ) 
  )          ;end cond 
 
  (setq  Initdir  (getvar "dwgprefix") 
  DxfExt  ".dxf" 
  BackUp  "_Backup" 
  pass  nil 
  ) 
  ;;打开对话框控制函数 
  (GetEduDwgLst) 
 
  (if (and pass (not (null dwgfileLst))) 
    (progn 
      (setq Index   0 
      HOLDLSP (getvar "ACADLSPASDOC") 
      AcadApp (vlax-get-acad-object) 
      ) 
      ;;(setvar "acadlspasdoc" 0) 
      (repeat (length dwgfileLst) 
  (setq DwgName   (nth Index dwgfileLst) 
        BaseName   (vl-filename-base DwgName) 
        filepath   (vl-filename-directory DwgName) 
        dxfFile   (vl-filename-mktemp BaseName filepath DxfExt) 
        BackupFile (strcat (getfullpath filepath) 
         BaseName 
         BackUp 
         (vl-filename-extension DwgName) 
       ) 
       ;;以下语句直接打开会有“ 解密数据时出错”提示，导致不能打开文件 
       ;;因此改为用objectdbx转存为dxf文件，在打开dxf保存为dwg文件 
       ;;DocObj   (vla-open (vla-get-documents AcadApp) DwgName) 
  ) 
  ;;利用objectdbx转存文件 
  (Dwg2Dxf DwgName dxfFile) 
  ;;检查原dwg文件的备份文件名是否存在，如果存在，则删除 
  (if (findfile BackupFile) 
    (deletefile BackupFile) 
  ) 
  ;;修改原dwg文件名 
  (vl-file-rename DwgName BackupFile) 
  ;;打开dxf文件 
  (setq DocObj (vla-open (vla-get-documents AcadApp) dxfFile)) 
  ;;再存为2007版dwg文件 
  (vla-saveas DocObj DwgName ac2007_dwg) 
  (vla-close DocObj :vlax-false) 
  ;;删除dxf文件 
  (deletefile dxfFile) 
  (setq Index (1+ Index)) 
      )          ;end repeat 
 
      (setvar "acadlspasdoc" HOLDLSP) 
      (if DocObj 
  (vlax-release-object DocObj) 
      ) 
      (if AcadApp 
  (vlax-release-object AcadApp) 
      ) 
    )          ;end progn 
  )          ;end if 
 
  (setq *error* OldError) 
  (princ) 
)          ;end defun 
 
;;==============================公用函数========================== 
;;; 
;;=============获取全路径，即路径后有\================================= 
(defun GetFullPath (path) 
  (if (wcmatch path "*\\") 
    path 
    (strcat path "\\") 
  ) 
)          ;end defun 
 
;;;============================获取文件夹程序================================= 
;;;根据Express tools是否安装决定使用哪一个函数 
(defun GetFolderNew (InitDir msg / ArxFile Apptitle) 
  (setq  Apptitle "浏览文件夹" 
  ArxFile   "acetutil.arx" 
  ) 
  (if (findfile ArxFile) 
    (GetFolder3 Apptitle Msg InitDir) 
    (getFolder1 msg) 
  ) 
)          ;end defun 
 
;;;============================获取文件夹程序1================================= 
;;来自于明经秋枫 
;; 用法：(getFolder1 msg) 
;; 例子：(getFolder1 "选择文件夹:") 
;; 返回值：字符串，文件夹路径，如果点了cancel, 返回nil 
(defun GetFolder1 (msg / WinShell shFolder path catchit) 
      ;|=============================== 
3. 关于Shell.Application的使用 
3.1、创建 Shell 对象 
var Shell = new ActiveXObject("Shell.Application"); 
 
3.2、使用 Shell 属性及方法 
 
Shell.Application 
Shell.Parent 
 
Shell.CascadeWindows() 
Shell.TileHorizontally() 
Shell.TileVertically() 
Shell.ControlPanelItem(sDir) /* 比如：sysdm.cpl */ 
Shell.EjectPC() 
Shell.Explore(vDir) 
Shell.Open(vDir) 
Shell.FileRun() 
Shell.FindComputer() 
Shell.FindFiles() 
Shell.Help() 
Shell.MinimizeAll() 
Shell.UndoMinimizeALL() 
Shell.RefreshMenu() 
Shell.SetTime() 
Shell.TrayProperties() 
Shell.ShutdownWindows() 
Shell.Suspend() 
oWindows = Shell.Windows() /* 返回ShellWindows对象 */ 
fFolder = Shell.NameSpace(vDir) /* 返回所打开的vDir的Folder对象 */ 
oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [, vRootFolder]) /* 选择文件夹对话框 */ 
/*示例： 
function BrowseFolder() 
{ 
var Message = "清选择文件夹"; 
 
var Shell = new ActiveXObject( "Shell.Application" ); 
var Folder = Shell.BrowseForFolder(0,Message,0x0040,0x11); 
if(Folder != null) 
{ 
Folder = Folder.items(); // 返回 FolderItems 对象 
Folder = Folder.item(); // 返回 Folderitem 对象 
Folder = Folder.Path; // 返回路径 
if(Folder.charAt(varFolder.length-1) != "\\"){ 
Folder = varFolder + "\\"; 
} 
return Folder; 
} 
} 
*/ 
 
/*示例： 
var Folder = Shell.NameSpace("C:\\"); // 返回 Folder对象 
*/ 
|; 
 
  (setq winshell (vlax-create-object "Shell.Application")) 
  (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1)) 
  (setq 
    catchit (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 
    (GetFullPath path) 
  ) 
)          ;end defun 
 
;;;============================获取文件夹程序3================================= 
;;;必须安装Express tools后才能使用 
(defun GetFolder3 (Apptitle Msg InitDir / ArxFile New_Path catchit) 
  (setq ArxFile "acetutil.arx") 
  (if (findfile ArxFile) 
    (arxload "acetutil.arx" NIL) 
    (exit) 
  ) 
 
  (setq  catchit  (vl-catch-all-apply 
      '(lambda () 
         (setq New_Path 
          (strcat 
            (strcase 
        (acet-ui-pickdir 
          Msg 
          (vl-string-right-trim "\\" InitDir) 
          Apptitle 
        ) 
            ) 
          ) 
         ) 
       ) 
    ) 
  ) 
  (if (vl-catch-all-error-p catchit) 
    nil 
    (GetFullPath New_Path) 
  ) 
)          ;end defun 
 
;;============;;注册"MSComDlg.CommonDialog"============================= 
(defun Regdlg () 
  (vl-registry-write 
    "HKEY_CLASSES_ROOT\\LICENSES\\4d553650-6abe-11cf-8adb-00aa00c00905" 
    "" 
    "gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj" 
  ) 
)          ;end defun 
 
;;=========================vlisp如何打开多重选择文件对话框函数======================== 
;;来自于明经 
;;调用示例 
;|(defun C:msfile  (/ flags diatl filter initdir) 
  (setq  flags  (+ 4 512 4096 32768 524288 1048576) 
  diatl  "选择文件" 
  filter  "图形文件(*.dwg)|*.dwg|所有文件(*.*)|*.*" 
  initdir  (getvar "dwgprefix") 
  ) 
  (GetMultiFiles flags diatl filter initdir) 
)          ;end defun 
|; 
(defun GetMultiFiles (flags  diatl    filter    initdir   / 
          index  wincomdlg filem      mfile     catchit 
         ) 
  ;;首先判断是否已经注册，如果未注册，先注册，此操作需要重新启动CAD 
  (if (setq wincomdlg (vlax-create-object "MSComDlg.CommonDialog")) 
    (progn 
      (vlax-put-property wincomdlg 'CancelError :vlax-true) 
      (vlax-put-property wincomdlg 'MaxFileSize 32767) 
      (vlax-put-property 
  wincomdlg 
  'Flags 
  flags 
      ) 
      (vlax-put-property wincomdlg 'DialogTitle diatl) 
      (vlax-put-property wincomdlg 'Filter filter) 
      (vlax-put-property wincomdlg 'InitDir initdir) 
      (setq 
  catchit  (vl-catch-all-apply  ;捕获错误 
      '(lambda () 
         (vlax-invoke-method wincomdlg 'ShowOpen) 
         (setq filem (vlax-get wincomdlg 'filename)) 
       ) 
    ) 
      ) 
      (vlax-release-object wincomdlg) 
      (if (vl-catch-all-error-p catchit) 
  nil        ;此时选择的是取消 
  (progn 
    (setq  Index 1 
    filem (FSTR->LST filem) 
    ) 
    (if filem 
      (if  (= 2 (length filem)) 
        (setq 
    mfile 
     (list (strcase (strcat (car filem) (cadr filem)) T) 
     ) 
        ) 
        (repeat (1- (length filem)) 
    (setq mfile (append 
            mfile 
            (list (strcase 
              (strcat (car filem) 
                "\\" 
                (nth index filem) 
              ) 
              T 
            ) 
            ) 
          ) 
          index (1+ index) 
    ) 
        )        ;end repeat 
      )        ;end if 
    )        ;end if 
  )        ;end progn 
      )          ;end if 
    ) 
    (progn 
      (alert "当前系统无MSComDlg.CommonDialog对象！") 
      (Regdlg) 
    ) 
  ) 
  mfile          ;返回值 
)          ;end defun 
 
;;============将输入的数据转换为字符串列表=================== 
(defun FSTR->LST (FM / N ff) 
  (setq FF NIL) 
  (IF (VL-STRING-POSITION (ASCII "\000") FM) 
    (PROGN 
      (WHILE (VL-STRING-POSITION (ASCII "\000") FM) 
  (SETQ N (VL-STRING-POSITION (ASCII "\000") FM)) 
  (SETQ FF (APPEND FF (LIST (SUBSTR FM 1 N)))) 
  (SETQ FM (SUBSTR FM (+ N 2) (- (STRLEN FM) N 1))) 
      ) 
      (SETQ FF (APPEND FF (LIST FM))) 
    ) 
    (PROGN 
      (SETQ FF (VL-FILENAME-DIRECTORY FM)) 
      (SETQ FF (LIST FF (VL-STRING-SUBST "" FF FM))) 
    ) 
  ) 
)          ;end defun 
 
;;=============获取指定文件夹(不包括子文件夹)下所有满足扩展名的文件=========== 
;;返回列表文件表元素全为小写 
(defun GetAllSpecFilesInFolder (dir filter) 
  (mapcar 
    (function 
      (lambda (file) 
  (strcase (strcat (getfullpath dir) file) T) 
      ) 
    ) 
    (vl-directory-files dir filter 1) 
  ) 
)          ;end defun 
 
;;=============获取指定文件夹(包括子文件夹)下所有满足扩展名的文件=========== 
(defun GetAllSpecFilesInFolders  (dir filter / filenames) 
  (setq  filenames (mapcar 
        (function 
          (lambda (file) 
      (strcase (strcat (getfullpath dir) file) T) 
      ;;递归出口 
          ) 
        ) 
        (vl-directory-files dir filter 1) 
      ) 
  ) 
  (mapcar 
    (function 
      (lambda (subdir) 
  ;; 此处递归 
  (setq filenames  (append  filenames 
        (GetAllSpecFilesInFolders 
          (strcat (getfullpath dir) subdir) 
          filter 
        ) 
      ) 
  ) 
      ) 
    ) 
    (vl-remove-if 
      (function  (lambda  (subdir) 
      (member subdir '("." "..")) 
    ) 
      ) 
      (vl-directory-files dir nil -1) 
    ) 
  ) 
 
  filenames 
)          ;end defun 
 
;;;定义VB中对话框msgbox几个输入常数:全局变量 
;; MsgBox(prompt[, buttons][, title][, helpfile, context]) 
;; Buttons: 
;; vbOKOnly          0 Display OK button only. 
;; vbOKCancel        1 Display OK and Cancel buttons. 
;; vbAbortRetryIgnore      2 Display Abort, Retry, and Ignore buttons. 
;; vbYesNoCancel        3 Display Yes, No, and Cancel buttons. 
;; vbYesNo          4 Display Yes and No buttons. 
;; vbRetryCancel        5 Display Retry and Cancel buttons. 
;; vbCritical       16 Display Critical Message icon. 
;; vbQuestion       32 Display Warning Query icon. 
;; vbExclamation       48 Display Warning Message icon. 
;; vbInformation       64 Display Information Message icon. 
;; vbDefaultButton1        0 First button is default. 
;; vbDefaultButton2      256 Second button is default. 
;; vbDefaultButton3      512 Third button is default. 
;; vbDefaultButton4      768 Fourth button is default. 
;; vbApplicationModal      0 Application modal; the user must respond to the message box before continuing work in the current application. 
;; vbSystemModal     4096 System modal; all applications are suspended until the user responds to the message box. 
(setq vbOKOnly 0) 
(setq vbOKCancel 1) 
(setq vbAbortRetryIgnore 2) 
(setq vbYesNoCancel 3) 
(setq vbYesNo 4) 
(setq vbRetryCancel 5) 
(setq vbCritical 16 
      vbQuestion 32 
) 
(setq vbExclamation   48 
      vbInformation   64 
      vbDefaultButton1   0 
      vbDefaultButton2   256 
      vbDefaultButton3   512 
      vbDefaultButton4   768 
      vbApplicationModal 0 
      vbSystemModal   4096 
) 
;;返回值 
;;1  OK button 
;;2  Cancel button 
;;3  Abort button 
;;4  Retry button 
;;5  Ignore button 
;;6  Yes button 
;;7  No button 
(setq rs_OK 1 
      rs_Cancel  2 
      rs_Abort 3 
      rs_Retry 4 
      rs_Ignore  5 
      rs_Yes 6 
      rs_No 7 
) 
 
;; A cute little utility to invoke a VBA message box and return a value to AutoLisp. 
;; Requires AutoCAD 2000 (R15) or higher. 
;; The buttons are a Boolean value representing a logical sum of 
;; the following values: 
;;-------------------------------------------------------- 
;; MsgBox(prompt[, buttons][, title][, helpfile, context]) 
;; Buttons: 
;; vbOKOnly          0 Display OK button only. 
;; vbOKCancel        1 Display OK and Cancel buttons. 
;; vbAbortRetryIgnore      2 Display Abort, Retry, and Ignore buttons. 
;; vbYesNoCancel        3 Display Yes, No, and Cancel buttons. 
;; vbYesNo          4 Display Yes and No buttons. 
;; vbRetryCancel        5 Display Retry and Cancel buttons. 
;; vbCritical       16 Display Critical Message icon. 
;; vbQuestion       32 Display Warning Query icon. 
;; vbExclamation       48 Display Warning Message icon. 
;; vbInformation       64 Display Information Message icon. 
;; vbDefaultButton1        0 First button is default. 
;; vbDefaultButton2      256 Second button is default. 
;; vbDefaultButton3      512 Third button is default. 
;; vbDefaultButton4      768 Fourth button is default. 
;; vbApplicationModal      0 Application modal; the user must respond to the message box before continuing work in the current application. 
;; vbSystemModal     4096 System modal; all applications are suspended until the user responds to the message box. 
;;test：(MsgBox "This is a test!" vbOKCancel "Iceberg CAD Tools") 
(defun MsgBox (Title Buttons Message / useri1 value) 
  (vl-load-com) 
  (or *acad* (setq *acad* (vlax-get-acad-object))) 
  (setq useri1 (getvar "useri1")) 
  (acad-push-dbmod) 
  (vla-eval 
    *acad* 
    (strcat 
      "ThisDrawing.SetVariable \"USERI1\"," 
      "MsgBox (\"" 
      Message 
      "\"," 
      (itoa Buttons) 
      ",\"" 
      Title 
      "\")" 
    ) 
  ) 
  (setq value (getvar "useri1")) 
  (setvar "useri1" useri1) 
  (acad-pop-dbmod) 
  value 
)          ;end defun 
 
 
;;=========获取ObjectDBX版本字符串============ 
(defun GetObjectDBXVer (/ VERSION) 
  (if (>= (setq VERSION (atoi (getvar "acadver"))) 16) 
    (strcat "ObjectDBX.AxDbDocument." (itoa VERSION)) 
    nil 
  )     ;end if 
)     ;end defun 
 
;;;===========从图元表中提取dxf组码值函数组码值函数 
(defun dxf (Item dxfList /) (cdr (assoc Item dxfList))) ;defun 
 
;;=================删除文件函数=================== 
;; 能删除所有文件，不管只读、隐藏与否，都能删除 
;; vl-file-delete不能删除只读文件 
;;Scripting.FileSystemObject格式 
;;fso.DeleteFile ( filespec[, force] ) 
;;参数 
;; fso  必选项, 应为 FileSystemObject 的名称。 
;; filespec 必选项, 要删除的文件的名称,filespec 可以在最后的路径成分中包含通配字符。 
;; force   可选项, Boolean 值，如果要删除设置了只读属性的文件，则为 true ；如果不删除则为 false （默认）。 
;; Arguments [Typ]: 
;;   Fil = FileName, "C:\\test\\Autoexec.bat" [STR] 
;; Notes: 
;;   - Requires ScrRun.dll. 
;; USAGE: (DelFile "C:\\test\\*.*") 
;; USAGE: (DelFile "C:\\test\\Autoexec.bat") 
(defun DeleteFile (FIL / FILSYS FILDIR SS ENT) 
  (setq FILSYS (vlax-create-object "Scripting.FileSystemObject")) 
  (setq FILDIR (vl-filename-directory FIL)) 
  (setq 
    SS (vl-directory-files 
  FILDIR 
  (strcat (vl-filename-base FIL) (vl-filename-extension FIL)) 
  1 
       ) 
  ) 
  (foreach ENT SS 
    (vlax-invoke 
      FILSYS 
      "deletefile" 
      (strcat FILDIR "\\" ENT) 
      :vlax-false 
    ) 
  ) 
  (vlax-release-object FILSYS) 
  (princ) 
)    
 ;end defun 
(defun makelist        (str pat / i j n lst) 
 ;;生成表记录函数：把字符串变为表 
   (cond 
     ((/= (type str) (type pat) 'STR)) 
     ((= str pat) '("")) 
     (T 
      (setq i 0 
            n (strlen pat) 
      ) 
      (while (setq j (vl-string-search pat str i)) 
        (setq lst (cons (substr str (1+ i) (- j i)) lst) 
              i         (+ j n) 
        ) 
      ) 
      (reverse (cons (substr str (1+ i)) lst)) 
     ) 
   ) 
 ) 
 
(defun GetObjectDBXVer (/ VERSION) 
   (if (>= (setq VERSION (atoi (getvar "acadver"))) 16) 
     (strcat "ObjectDBX.AxDbDocument." (itoa VERSION)) 
     nil 
   )     ;end if 
 )     ;end defun 
 
;;;===========从图元表中提取dxf组码值函数组码值函数 
 (defun dxf (Item dxfList /) (cdr (assoc Item dxfList))) ;defun 
 
;;=================删除文件函数=================== 
 ;; 能删除所有文件，不管只读、隐藏与否，都能删除 
 ;; vl-file-delete不能删除只读文件 
 ;;Scripting.FileSystemObject格式 
 ;;fso.DeleteFile ( filespec[, force] ) 
 ;;参数 
 ;; fso  必选项, 应为 FileSystemObject 的名称。 
 ;; filespec 必选项, 要删除的文件的名称,filespec 可以在最后的路径成分中包含通配字符。 
 ;; force   可选项, Boolean 值，如果要删除设置了只读属性的文件，则为 true ；如果不删除则为 false （默认）。 
 ;; Arguments [Typ]: 
 ;;   Fil = FileName, "C:\\test\\Autoexec.bat" [STR] 
 ;; Notes: 
 ;;   - Requires ScrRun.dll. 
 ;; USAGE: (DelFile "C:\\test\\*.*") 
 ;; USAGE: (DelFile "C:\\test\\Autoexec.bat") 
 (defun DeleteFile (FIL / FILSYS FILDIR SS ENT) 
   (setq FILSYS (vlax-create-object "Scripting.FileSystemObject")) 
   (setq FILDIR (vl-filename-directory FIL)) 
   (setq 
     SS (vl-directory-files 
   FILDIR 
   (strcat (vl-filename-base FIL) (vl-filename-extension FIL)) 
   1 
        ) 
   ) 
   (foreach ENT SS 
     (vlax-invoke 
       FILSYS 
       "deletefile" 
       (strcat FILDIR "\\" ENT) 
       :vlax-false 
     ) 
   ) 
   (vlax-release-object FILSYS) 
   (princ) 
 )     ;end defun 
 
 
(defun AddSeprate (DataList delimiter / i len dealdata TempData) 
 ;;添加分隔符函数 
   (setq i   1 
 len (length DataList) 
   ) 
   (if len 
     (progn 
       (setq dealdata (nth 0 DataList)) 
       (if (numberp dealdata) 
 (setq dealdata (rtos dealdata 2)) 
       ) 
       (repeat (1- len) 
 (setq TempData (nth i DataList)) 
 (if (numberp TempData) 
    (setq TempData (rtos TempData 2)) 
 ) 
 (setq dealdata (strcat dealdata delimiter TempData)) 
 (setq i (1+ i)) 
       ) 
     ) 
   ) 
   (setq DataList dealdata) 
 )

awd37 · 发表于 2012-12-16 05:30

非常感谢！！！！

awd37 · 发表于 2012-12-16 05:33

没有权限，很郁闷

awd37 · 发表于 2012-12-16 06:09

学习了很多用法。谢谢~

自贡黄明儒 · 发表于 2012-12-31 09:40

本帖最后由自贡黄明儒于 2012-12-31 09:43 编辑

hehoubin 发表于 2012-12-9 18:36

1 是不是可以考虑加一个wblock命令，达到批量瘦身的作用？
2 或者加一个查找替换文字,就更完美了。

自贡黄明儒 · 发表于 2012-12-31 11:37

hehoubin 发表于 2012-12-9 18:36

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

hehoubin · 发表于 2013-1-1 21:14

谢谢自贡黄明儒发表于昨天 11:37

学习了

账号		自动登录	找回密码
密码			注册

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

评分

本帖子中包含更多资源