DWG批量去教育版/版本转换/减肥瘦身/查找替换

自贡黄明儒 · 发表于 2013-1-18 19:19:20

本帖最后由自贡黄明儒于 2013-11-11 13:16 编辑

1 前言：我最喜欢批量处理东西了，比如给圆和封闭多边形加中心线、文字对齐。。。

2 说明：

2.1 本程序用vl编写

2.2 从iceberg2509 的批量去教育版/版本转换一贴，可以学到许多实用的东西，可我一直没有将此派上用场，原因是要2010版本才能使用；已经打开的文件不能处理。

2.3 批量文字查找替换，有一个被雪山飞狐加精的帖子，可惜是VB版的。

2.4 我试图将上面功能弄成一个界面，想想也就算了，麻烦，能用就行了。

3 命令：out MyFind

4 功能：

4.1 Out 批量去教育版、批量版本转换、批量减肥瘦身

4.2 MyFind 批量减肥瘦身、批量文字查找替换

5 后语：欢迎试用

6 【参考文献】

6.1 iceberg2509 的批量去教育版、批量版本转换

6.2 highflybir的块变色

6.3 Gu_xl 的文字查找替换

6.4 狂刀的文字查找替换

7 提示：处理打开的文件前须保存

=========================================================================

1 Hellow写的DWG|DXF通用转换器，速度确实很快，但有时处理不了。
2 Caoyin发的EduPlotStamp.exe(69楼)放在支持目录下，则可以处理激活文档。
3 今天这个改进版似乎好些，但速度慢了
4 修正了上一版的一个错误(列表中只添加打开的文件时，“确定”按钮不起作用)

;;=================DWG文件版本批量处理程序=====================
;;改编自iceberg2509的程序自贡黄明儒 2013.1.6
(defun C:out (/ DCL_ID DWGFILELST DWGTYPE
EDIT_FIN1 EDIT_INS1 EDUPLOTST HASOPENFILES
HOLDLSP INDEX INITDIR LST_DWGFILE
MYERROR OLDERROR POP_VER RETURN#
TMPFILE TOG_CON1 TOG_DEL1 TOG_FIN1
TOG_SUBFOLDER TOG_WBL1 X
)
;;1.1=============查找替代状态函数=======================
(defun tog_FinDo (tog_Fin1)
(if (= tog_Fin1 "1")
(progn (mode_tile "edit_Fin" 0) (mode_tile "edit_Ins" 0))
(progn (mode_tile "edit_Fin" 1) (mode_tile "edit_Ins" 1))
)
)
;;1.2=============移除按钮状态函数=======================
(defun DelBtnIsEnabled ()
(if lst_DwgFile
(mode_tile "but_del" 0)
(mode_tile "but_del" 1)
)
)
;;1.3=============确认按钮是否激活函数=======================
(defun OkBtnIsEnabled ()
(if (null dwgfileLst)
(mode_tile "but_OK" 1)
(mode_tile "but_OK" 0)
)
)
;;1.4=============转换版本状态函数=======================
(defun tog_conDo (tog_con1)
(if (= tog_con1 "1")
(mode_tile "pop_ver" 0)
(mode_tile "pop_ver" 1)
)
)
;;2============获取指定文件夹下的所有dwg文件=================
;;对本程序，Initdir是全局变量,故使用此函数前须赋值
(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)
)
)
)[/align][align=left] ;;3============加载dwg文件到列表==============
;;DWGFILELST HASOPENFILES对于本程序是全局
(defun LoadDwgFileLst
(fileslst / DWGFILELST1 HASOPENFILES1 TMPFILE N)
(if fileslst
(progn
(setq fileslst (SuccessOpenFiles fileslst))
;对其中非打开文件进行检查,看是否能打开
(setq HasOpenFiles1 (vl-remove-if 'VL-FILE-SYSTIME fileslst)
dwgfileLst1 (vl-remove-if-not 'VL-FILE-SYSTIME fileslst)
)
(if dwgfileLst
(repeat (setq n (length dwgfileLst1))
(setq tmpfile (nth (setq n (1- n)) dwgfileLst1))
(if (member tmpfile dwgfileLst)
nil
(setq dwgfileLst
(append dwgfileLst
(list (strcase tmpfile T))
)
)
)
)
(setq dwgfileLst dwgfileLst1)
)
(if HasOpenFiles
(repeat (setq n (length HasOpenFiles1))
(setq tmpfile (nth (setq n (1- n)) HasOpenFiles1))
(if (member tmpfile HasOpenFiles)
nil
(setq HasOpenFiles
(append HasOpenFiles
(list (strcase tmpfile T))
)
)
)
)
(setq HasOpenFiles HasOpenFiles1)
)[/align][align=left] (start_list "lst_DwgFile")
(if HasOpenFiles
(progn (setq HasOpenFiles (vl-sort HasOpenFiles '<))
(mapcar 'add_list HasOpenFiles)
)
)
(if dwgfileLst
(progn (setq dwgfileLst (vl-sort dwgfileLst '<))
(mapcar 'add_list dwgfileLst)
)
)
(end_list)
)
)
(OkBtnIsEnabled)
)
;;3.1 检查非打开文件,返回能成功能打开的文件列表
(defun SuccessOpenFiles
(fileslst / DWGFILELST
HASOPENFILES N NOTOPENFILELST
TMPFILE
)
(setq HasOpenFiles (vl-remove-if 'VL-FILE-SYSTIME fileslst)
dwgfileLst (vl-remove-if-not 'VL-FILE-SYSTIME fileslst)
)
(if dwgfileLst
(repeat (setq n (length dwgfileLst))
(setq tmpfile (nth (setq n (1- n)) dwgfileLst))
(if (CanSuccessOpen tmpfile)
(setq NotOpenFileLst (cons tmpfile NotOpenFileLst))
)
)
)
(if NotOpenFileLst
(progn
(repeat (setq n (length NotOpenFileLst))
(setq tmpfile (nth (setq n (1- n)) NotOpenFileLst))
(setq dwgfileLst (vl-remove tmpfile dwgfileLst))
)
(alert
(strcat
"以下文件可能已经损坏，或者需要高版本才能打开，无法添加到列表：\n"
(AddSeprate NotOpenFileLst "\n")
)
)
)
)
(append HasOpenFiles dwgfileLst)
)
;;3.2 对于非打开文件进行检查,看是否能打开
(defun CanSuccessOpen (DwgName / ACADAPP CATCHIT DBXDOC)
(setq AcadApp (vlax-get-acad-object)
dbxDoc (vla-GetInterfaceObject
AcadApp
(GetObjectDBXVer)
)
)
(setq catchit (vl-catch-all-apply 'vla-open (list dbxDoc DwgName)))
(if dbxDoc
(vlax-release-object dbxDoc)
) ;关闭文档
(if AcadApp
(vlax-release-object AcadApp)
)
(vl-catch-all-error-p catchit)
)[/align][align=left] ;;4===============获取选中的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)
)
)
)
;;4.1=========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)
)
)
)
)
)
)
)
(progn
(alert "当前系统无MSComDlg.CommonDialog对象！")
(Regdlg)
)
)
mfile
)[/align][align=left] ;;5==============移除选定文件函数=======================
;;DWGFILELST HASOPENFILES LST_DWGFILE对于本程序是全局
(defun RemoveDwgFiles (/ IndexLst RemoveDwgLst INDEX TMPFILE)
(if lst_DwgFile
(progn
(setq IndexLst (makelist lst_DwgFile " ")
RemoveDwgLst (mapcar '(lambda (index)
(nth (atoi index)
(append HasOpenFiles dwgfileLst)
)
)
IndexLst
)
)
;;移除选定文件
(mapcar '(lambda (tmpfile)
(setq HasOpenFiles
(vl-remove (strcase tmpfile T) HasOpenFiles)
)
)
RemoveDwgLst
)
(mapcar '(lambda (tmpfile)
(setq dwgfileLst
(vl-remove (strcase tmpfile T) dwgfileLst)
)
)
RemoveDwgLst
)
(start_list "lst_DwgFile")
(if HasOpenFiles
(mapcar 'add_list HasOpenFiles)
)
(if dwgfileLst
(mapcar 'add_list dwgfileLst)
)
(end_list)
(setq lst_DwgFile nil)
)
)
(DelBtnIsEnabled)
(OkBtnIsEnabled)
)[/align][align=left] ;;6.1=============初始化对话框函数=======================
(defun setdata-1 ()
(cond
((= (fix (atof (getvar "acadver"))) 16)
(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)
)
)
)
((= (fix (atof (getvar "acadver"))) 17)
(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)
)
)
)
(T
(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等就不会求值了，导致后续程序取值错误
)
)
)
(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")
)
)
;;6.2=============取得用户对话框选择=============
(defun getdata-1 ()
(setq tog_del1 (get_tile "tog_del"))
(setq tog_con1 (get_tile "tog_con"))
(setq tog_Wbl1 (get_tile "tog_Wbl"))
(setq tog_Fin1 (get_tile "tog_Fin"))
(setq edit_Fin1 (get_tile "edit_Fin"))
(setq edit_Ins1 (get_tile "edit_Ins"))
(setq pop_ver (get_tile "pop_ver"))
)
;;6.3=============对话框驱动函数==================
(defun ConvDwgLst (/ DCLID FN FNAME LIN TOG_FIN1 X)
(setq fname (vl-filename-mktemp nil nil ".dcl"))
(setq fn (open fname "w"))
(write-line
"dcl_settings : default_dcl_settings { audit_level = 3; }"
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
" : boxed_column{label = "文件选择";"
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 " }" fn)
(write-line " spacer;" fn)
(write-line
" : boxed_column{label = "操作选择";"
fn
)
(write-line " : toggle {" fn)
(write-line " label = "去教育版";" fn)
(write-line
" key = "tog_del"; "
fn
)
(write-line " }" fn)
(write-line " : toggle {" fn)
(write-line " label = "版本转换";" fn)
(write-line " value = "1";" fn)
(write-line " key = "tog_con";" fn)
(write-line " }" fn)
(write-line " : toggle {" fn)
(write-line " label = "减肥瘦身";" fn)
(write-line " key = "tog_Wbl";" fn)
(write-line " }" fn)
(write-line " }" fn)
(write-line " spacer;" fn)
(write-line
" : boxed_column{label = "执行选择";"
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 " } " 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)[/align][align=left] (setdata-1) ;初始化对话框
(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
"tog_Fin"
"(setq tog_Fin1 $$value)(tog_FinDo tog_Fin1)"
)
(action_tile
"tog_con"
"(setq tog_con1 $$value)(tog_conDo tog_con1)"
)
(action_tile "but_OK" "(getdata-1)(done_dialog 1)")
(action_tile "but_Cancel" "(done_dialog 0)")
(setq return# (start_dialog))
(unload_dialog dclid)
(close fn)
(vl-file-delete fname)
(if (and (= return# 1) (or(not (null dwgfileLst))(not (null HasOpenFiles))))
(progn
(if (= TOG_WBL1 "1")
(progn (DwgWblock dwgfileLst)
(DwgWblock1 HasOpenFiles)
)
)
(if (= tog_del1 "1")
(progn (if dwgfileLst
(DelEduLog dwgfileLst)
)
(if HasOpenFiles
(DelEduLog1 HasOpenFiles)
)
)
)
(if (= tog_con1 "1")
(progn (DwgConverter POP_VER dwgfileLst)
(DwgConverter1 POP_VER HasOpenFiles)
)
) [/align][align=left] )
)
)[/align][align=left] ;;7===========定义容错函数===============
(defun MyError (msg)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
(= msg "函数被取消")
(= msg "函数已取消")
)
(princ)
(princ (strcat "\n 错误:" msg "\n"))
)
(setvar "acadlspasdoc" HOLDLSP)
(princ)
)[/align][align=left] ;;8=================dwg转dxf文件函数================
(defun Dwg2Dxf (DwgName dxfName / AcadApp dbxDoc)
(setq AcadApp (vlax-get-acad-object)
dbxDoc (vla-GetInterfaceObject
AcadApp
(GetObjectDBXVer)
)
)
(vla-open dbxDoc DwgName)
;;(vla-saveas dbxDoc DwgName ac2000_dxf)
;;(vla-close dbxDoc :vlax-false)
(vlax-invoke dbxDoc "dxfout" dxfName)
;原来这句好好的，现在怎么不行了?
(if dbxDoc
(vlax-release-object dbxDoc)
) ;关闭文档
(if AcadApp
(vlax-release-object AcadApp)
)
)[/align][align=left] ;;9.1==============非打开的文件版本转换================
;;DWGTYPE 对于本函数是全局
(defun DwgConverter (POP_VER dwgfileLst / ACADAPP
BASENAME DOCOBJ DWGNAME DWGVER
DXFFILE FILEEXT FILEPATH INDEX
NEWFILE
)
;;===从图元表中提取dxf组码值函数组码值函数
(defun dxf (Item dxfList) (cdr (assoc Item dxfList)))[/align][align=left] (setq AcadApp (vlax-get-acad-object))
(setq pop_ver (atoi pop_ver))
(setq DwgVer (last (dxf pop_ver DwgType)))
(if (= (/ pop_ver 2) pop_ver) ;偶数
(setq FileExt ".dwg")
(setq FileExt ".dxf")
)
(repeat (setq Index (length dwgfileLst))
(setq DwgName (nth (setq Index (1- 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)
)
(setq DocObj (vla-open (vla-get-documents AcadApp) DwgName))
(vla-saveas DocObj NewFile DwgVer) ;将原dwg文件存为指定版本的
(vla-close DocObj :vlax-false)
(if (= FileExt ".dxf")
(progn
;;改为dwg同名文件
(if (findfile DxfFile)
(deletefile DxfFile)
)
(vl-file-rename NewFile DxfFile)
)
(progn
(deletefile DwgName)
;;新保存的文件名改为原dwg文件名
(vl-file-rename NewFile DwgName)
)
)
)[/align][align=left] (if DocObj
(vlax-release-object DocObj)
)
(if AcadApp
(vlax-release-object AcadApp)
)
)
;;9.2============已经打开的文件版本转换================
(defun DwgConverter1 (POP_VER HasOpenFiles / *ACAD* *DOCS* DWGNAME N)
(setq *ACAD* (vlax-get-acad-object))
;;关闭
(repeat (setq n (length HasOpenFiles))
(setq DwgName (nth (setq n (1- n)) HasOpenFiles))
(vlax-for item (vla-get-Documents *ACAD*)
(if (= (strcase (vlax-get-property item 'FullName))
(strcase DwgName)
)
(vla-close item :vlax-false)
)
)
)
;;版本转换
(DwgConverter POP_VER HasOpenFiles)
;;再打开
(setq *DOCS* (vla-get-documents *ACAD*))
(repeat (setq n (length HasOpenFiles))
(setq DwgName (nth (setq n (1- n)) HasOpenFiles))
(vla-open *DOCS* DwgName)
)
)[/align][align=left] ;;10.1============非打开的文件去除教育版标记================
(defun DelEduLog (dwgfileLst / BACKUP BACKUPFILE
BASENAME AcadApp DOCOBJ DWGNAME
DXFEXT DXFFILE FILEPATH INDEX
)
(setq DxfExt ".dxf"
BackUp "_Backup"
)
(setq AcadApp (vlax-get-acad-object))
(repeat (setq Index (length dwgfileLst))
(setq DwgName (nth (setq Index (1- 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文件
(Dwg2Dxf DwgName dxfFile)
;;备份文件存在，则删除
(if (findfile BackupFile)
(deletefile BackupFile)
)
;;修改原dwg文件为备份文件
(vl-file-rename DwgName BackupFile)
;;打开dxf文件
(if (setq DocObj (vla-open (vla-get-documents AcadApp) dxfFile))
(progn (deletefile BackupFile)
;;再存为2000版dwg文件
(vla-saveas DocObj DwgName ac2000_dwg)
(vla-close DocObj :vlax-false)
;;删除dxf文件
(deletefile dxfFile)
)
)
)
(if DocObj
(vlax-release-object DocObj)
)
(if AcadApp
(vlax-release-object AcadApp)
)
)
;;10.2============已经打开的文件去除教育版标记================
(defun DelEduLog1 (HasOpenFiles / *ACAD* *DOCS* DWGNAME N)
(setq *ACAD* (vlax-get-acad-object))
;;关闭
(repeat (setq n (length HasOpenFiles))
(setq DwgName (nth (setq n (1- n)) HasOpenFiles))
(vlax-for item (vla-get-Documents *ACAD*)
(if (= (strcase (vlax-get-property item 'FullName))
(strcase DwgName)
)
(vla-close item :vlax-false)
)
)
)
;;去除教育
(DelEduLog HasOpenFiles)
;;再打开
(setq *DOCS* (vla-get-documents *ACAD*))
(repeat (setq n (length HasOpenFiles))
(setq DwgName (nth (setq n (1- n)) HasOpenFiles))
(vla-open *DOCS* DwgName)
)
)
;;11.1============非打开的文件减肥瘦身================
(defun DwgWblock (dwgfileLst / ACADAPP BACKUPFILE
BASENAME DOCOBJ DWGNAME FILEPATH
INDEX NEWSET SSETS
)
(setq AcadApp (vlax-get-acad-object))
(repeat (setq Index (length dwgfileLst))
(setq DwgName (nth (setq Index (1- Index)) dwgfileLst))
(setq BaseName (vl-filename-base DwgName)
filepath (vl-filename-directory DwgName)
;;dxfFile (vl-string-subst ".dxf" ".dwg" DwgName)
BackupFile (strcat (getfullpath filepath)
BaseName
"_Backup"
(vl-filename-extension DwgName)
)
)
(if (findfile BackupFile)
(deletefile BackupFile)
) ;检查原dwg文件的备份文件名是否存在，如果存在，则删除
(if (vl-file-rename DwgName BackupFile) ;修改原dwg文件名
(progn
(setq
DocObj (vla-open (vla-get-documents AcadApp) BackupFile)
)
(setq ssets (vla-get-selectionsets DocObj))
(if (vl-catch-all-error-p
(vl-catch-all-apply 'vla-item (list ssets "$$Set"))
)
(setq newSet (vla-add ssets "$$Set"))
(progn
(vla-delete (vla-item ssets "$$Set"))
(setq newSet (vla-add ssets "$$Set"))
)
)
;;select all objects in the drawing
(vla-Select newSet acSelectionSetAll)
(vla-WBlock DocObj DwgName newSet)
(vla-close DocObj :vlax-false)
(deletefile BackupFile)
)
)
)
(if DocObj
(vlax-release-object DocObj)
)
(if AcadApp
(vlax-release-object AcadApp)
)
)
;;11.2============已经打开的文件减肥瘦身================
(defun DwgWblock1 (HasOpenFiles / *ACAD* *DOCS* DWGNAME N)
(setq *ACAD* (vlax-get-acad-object))
;;关闭
(setq HasOpenFiles (mapcar 'strcase HasOpenFiles))
(vlax-for item (vla-get-Documents *ACAD*)
(if (member (strcase (vlax-get-property item 'FullName))
HasOpenFiles
)
(vla-close item :vlax-false)
)
)
;;减肥瘦身
(DwgWblock HasOpenFiles)
;;再打开
(setq *DOCS* (vla-get-documents *ACAD*))
(repeat (setq n (length HasOpenFiles)) ;使用foreach失败，原因待查
(setq DwgName (nth (setq n (1- n)) HasOpenFiles))
(vla-open *DOCS* DwgName)
)
)
;;15=================主函数===========
(setq OldError *error*
*error* MyError
HOLDLSP (getvar "ACADLSPASDOC")
)
(setvar "acadlspasdoc" 0)
(setvar "cmdecho" 0)
;;(if (not MsgBox)(load "MsgBox"))[/align][align=left] (cond
((< (atof (getvar "acadver")) 16) ;检查版本
;|(MsgBox "版本检查"
64
"此程序只能运行在AutoCAD 2004或更高版本!"
)|;
(alert "此程序只能运行在AutoCAD 2004或更高版本!")
(exit)
)
((/= 1 (getvar "dwgtitled")) ;未保存过的文件
;;(setq dcl_id (load_dialog "dwgconverter"))
(setq Initdir (getvar "dwgprefix"))
(ConvDwgLst)
)
((= 1 (getvar "dwgtitled")) ;文件环境(保存过)
;|(MsgBox
"使用环境检查"
64
"批量处理只能在新建且未保存的文件中运行!\n\n当前文档未必能成功去除教育版印戳!"
)|;
(alert
"批量处理只能在新建且未保存的文件中运行!\n\n当前文档未必能成功去除教育版印戳!"
)
(if (setq EduPlotSt (findfile "EduPlotStamp.exe"))
(startapp EduPlotSt)
)
)
)
;;(setvar "acadlspasdoc" HOLDLSP)
(setq *error* OldError)
(gc)
(princ)
)[/align][align=left]
;;==============================公用函数==========================[/align][align=left];;1 =============获取全路径，即路径后有\=================================
(defun GetFullPath (path)
(if (wcmatch path "*\")
path
(strcat path "\")
)
)[/align][align=left];;2 ============================获取文件夹程序=================================
;;根据Express tools是否安装决定使用哪一个函数
(defun GetFolderNew (InitDir msg / ArxFile Apptitle)
(setq Apptitle "浏览文件夹"
ArxFile "acetutil.arx"
)
(if (findfile ArxFile)
(GetFolder3 Apptitle Msg InitDir)
(getFolder1 msg)
)
)
;;2.1 没有安装ET时选择的文件夹
;;来自于明经秋枫
;; 用法：(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)
)
)
;;2.2 安装ET后选择的文件夹
(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)
)
)[/align][align=left];;3 ============;;注册"MSComDlg.CommonDialog"=============================
(defun Regdlg ()
(vl-registry-write
"HKEY_CLASSES_ROOT\\LICENSES\\4d553650-6abe-11cf-8adb-00aa00c00905"
""
"gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj"
)
)[/align][align=left];;4 ============将输入的数据转换为字符串列表===================
(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)))
)
)
)[/align][align=left];;5.1 =============获取指定文件夹(不包括子文件夹)下所有满足扩展名的文件===========
;;返回列表文件表元素全为小写
(defun GetAllSpecFilesInFolder (dir filter)
(mapcar
(function
(lambda (file)
(strcase (strcat (getfullpath dir) file) T)
)
)
(vl-directory-files dir filter 1)
)
)
;;5.2 =============获取指定文件夹(包括子文件夹)下所有满足扩展名的文件===========
(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
)[/align][align=left] ;|;定义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[/align][align=left];;7 =========获取ObjectDBX版本字符串============
(defun GetObjectDBXVer (/ VERSION)
(if (>= (setq VERSION (atoi (getvar "acadver"))) 16)
(strcat "ObjectDBX.AxDbDocument." (itoa VERSION))
)
)[/align][align=left];;8 =================删除文件函数===================
;; 能删除所有文件，不管只读、隐藏与否，都能删除
;; 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)
)[/align][align=left];;9 生成表记录函数：把字符串变为表
(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))
)
)
)[/align][align=left];;10 添加分隔符函数
(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文件版本批量处理程序===================== 
;;改编自iceberg2509的程序 自贡黄明儒 2013.1.6 
(defun C:out (/     DCL_ID DWGFILELST   DWGTYPE 
       EDIT_FIN1    EDIT_INS1 EDUPLOTST    HASOPENFILES 
       HOLDLSP    INDEX INITDIR      LST_DWGFILE 
       MYERROR    OLDERROR POP_VER      RETURN# 
       TMPFILE    TOG_CON1 TOG_DEL1     TOG_FIN1 
       TOG_SUBFOLDER  TOG_WBL1     X 
      ) 
  ;;1.1=============查找替代状态函数======================= 
  (defun tog_FinDo (tog_Fin1) 
    (if (= tog_Fin1 "1") 
      (progn (mode_tile "edit_Fin" 0) (mode_tile "edit_Ins" 0)) 
      (progn (mode_tile "edit_Fin" 1) (mode_tile "edit_Ins" 1)) 
    ) 
  ) 
  ;;1.2=============移除按钮状态函数======================= 
  (defun DelBtnIsEnabled () 
    (if lst_DwgFile 
      (mode_tile "but_del" 0) 
      (mode_tile "but_del" 1) 
    ) 
  ) 
  ;;1.3=============确认按钮是否激活函数======================= 
  (defun OkBtnIsEnabled () 
    (if (null dwgfileLst) 
      (mode_tile "but_OK" 1) 
      (mode_tile "but_OK" 0) 
    ) 
  ) 
  ;;1.4=============转换版本状态函数======================= 
  (defun tog_conDo (tog_con1) 
    (if (= tog_con1 "1") 
      (mode_tile "pop_ver" 0) 
      (mode_tile "pop_ver" 1) 
    ) 
  ) 
  ;;2============获取指定文件夹下的所有dwg文件================= 
  ;;对本程序，Initdir是全局变量,故使用此函数前须赋值 
  (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) 
      ) 
    ) 
  )[/align][align=left]  ;;3============加载dwg文件到列表============== 
  ;;DWGFILELST HASOPENFILES对于本程序是全局 
  (defun LoadDwgFileLst 
  (fileslst / DWGFILELST1 HASOPENFILES1 TMPFILE N) 
    (if fileslst 
      (progn 
 (setq fileslst (SuccessOpenFiles fileslst)) 
     ;对其中非打开文件进行检查,看是否能打开 
 (setq HasOpenFiles1 (vl-remove-if 'VL-FILE-SYSTIME fileslst) 
       dwgfileLst1   (vl-remove-if-not 'VL-FILE-SYSTIME fileslst) 
 ) 
 (if dwgfileLst 
   (repeat (setq n (length dwgfileLst1)) 
     (setq tmpfile (nth (setq n (1- n)) dwgfileLst1)) 
     (if (member tmpfile dwgfileLst) 
       nil 
       (setq dwgfileLst 
       (append dwgfileLst 
        (list (strcase tmpfile T)) 
       ) 
       ) 
     ) 
   ) 
   (setq dwgfileLst dwgfileLst1) 
 ) 
 (if HasOpenFiles 
   (repeat (setq n (length HasOpenFiles1)) 
     (setq tmpfile (nth (setq n (1- n)) HasOpenFiles1)) 
     (if (member tmpfile HasOpenFiles) 
       nil 
       (setq HasOpenFiles 
       (append HasOpenFiles 
        (list (strcase tmpfile T)) 
       ) 
       ) 
     ) 
   ) 
   (setq HasOpenFiles HasOpenFiles1) 
 )[/align][align=left] (start_list "lst_DwgFile") 
 (if HasOpenFiles 
   (progn (setq HasOpenFiles (vl-sort HasOpenFiles '<)) 
   (mapcar 'add_list HasOpenFiles) 
   ) 
 ) 
 (if dwgfileLst 
   (progn (setq dwgfileLst (vl-sort dwgfileLst '<)) 
   (mapcar 'add_list dwgfileLst) 
   ) 
 ) 
 (end_list) 
      ) 
    ) 
    (OkBtnIsEnabled) 
  ) 
  ;;3.1 检查非打开文件,返回能成功能打开的文件列表 
  (defun SuccessOpenFiles 
     (fileslst  /        DWGFILELST 
      HASOPENFILES  N        NOTOPENFILELST 
      TMPFILE 
     ) 
    (setq HasOpenFiles (vl-remove-if 'VL-FILE-SYSTIME fileslst) 
   dwgfileLst   (vl-remove-if-not 'VL-FILE-SYSTIME fileslst) 
    ) 
    (if dwgfileLst 
      (repeat (setq n (length dwgfileLst)) 
 (setq tmpfile (nth (setq n (1- n)) dwgfileLst)) 
 (if (CanSuccessOpen tmpfile) 
   (setq NotOpenFileLst (cons tmpfile NotOpenFileLst)) 
 ) 
      ) 
    ) 
    (if NotOpenFileLst 
      (progn 
 (repeat (setq n (length NotOpenFileLst)) 
   (setq tmpfile (nth (setq n (1- n)) NotOpenFileLst)) 
   (setq dwgfileLst (vl-remove tmpfile dwgfileLst)) 
 ) 
 (alert 
   (strcat 
     "以下文件可能已经损坏，或者需要高版本才能打开，无法添加到列表：\n" 
     (AddSeprate NotOpenFileLst "\n") 
   ) 
 ) 
      ) 
    ) 
    (append HasOpenFiles dwgfileLst) 
  ) 
  ;;3.2 对于非打开文件进行检查,看是否能打开 
  (defun CanSuccessOpen (DwgName / ACADAPP CATCHIT DBXDOC) 
    (setq AcadApp (vlax-get-acad-object) 
   dbxDoc  (vla-GetInterfaceObject 
      AcadApp 
      (GetObjectDBXVer) 
    ) 
    ) 
    (setq catchit (vl-catch-all-apply 'vla-open (list dbxDoc DwgName))) 
    (if dbxDoc 
      (vlax-release-object dbxDoc) 
    )     ;关闭文档 
    (if AcadApp 
      (vlax-release-object AcadApp) 
    ) 
    (vl-catch-all-error-p catchit) 
  )[/align][align=left]  ;;4===============获取选中的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) 
      ) 
    ) 
  ) 
  ;;4.1=========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) 
    ) 
  ) 
       ) 
     ) 
   ) 
 ) 
      ) 
      (progn 
 (alert "当前系统无MSComDlg.CommonDialog对象！") 
 (Regdlg) 
      ) 
    ) 
    mfile 
  )[/align][align=left]  ;;5==============移除选定文件函数======================= 
  ;;DWGFILELST HASOPENFILES LST_DWGFILE对于本程序是全局 
  (defun RemoveDwgFiles (/ IndexLst RemoveDwgLst INDEX TMPFILE) 
    (if lst_DwgFile 
      (progn 
 (setq IndexLst    (makelist lst_DwgFile " ") 
       RemoveDwgLst (mapcar '(lambda (index) 
          (nth (atoi index) 
        (append HasOpenFiles dwgfileLst) 
          ) 
        ) 
       IndexLst 
      ) 
 ) 
 ;;移除选定文件 
 (mapcar '(lambda (tmpfile) 
     (setq HasOpenFiles 
     (vl-remove (strcase tmpfile T) HasOpenFiles) 
     ) 
   ) 
  RemoveDwgLst 
 ) 
 (mapcar '(lambda (tmpfile) 
     (setq dwgfileLst 
     (vl-remove (strcase tmpfile T) dwgfileLst) 
     ) 
   ) 
  RemoveDwgLst 
 ) 
 (start_list "lst_DwgFile") 
 (if HasOpenFiles 
   (mapcar 'add_list HasOpenFiles) 
 ) 
 (if dwgfileLst 
   (mapcar 'add_list dwgfileLst) 
 ) 
 (end_list) 
 (setq lst_DwgFile nil) 
      ) 
    ) 
    (DelBtnIsEnabled) 
    (OkBtnIsEnabled) 
  )[/align][align=left]  ;;6.1=============初始化对话框函数======================= 
  (defun setdata-1 () 
    (cond 
      ((= (fix (atof (getvar "acadver"))) 16) 
       (setq 
  DwgType (list (list 0 "<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a> 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) 
   ) 
       ) 
      ) 
      ((= (fix (atof (getvar "acadver"))) 17) 
       (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) 
   ) 
       ) 
      ) 
      (T 
       (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等就不会求值了，导致后续程序取值错误 
       ) 
      ) 
    ) 
    (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") 
    ) 
  ) 
  ;;6.2=============取得用户对话框选择============= 
  (defun getdata-1 () 
    (setq tog_del1 (get_tile "tog_del")) 
    (setq tog_con1 (get_tile "tog_con")) 
    (setq tog_Wbl1 (get_tile "tog_Wbl")) 
    (setq tog_Fin1 (get_tile "tog_Fin")) 
    (setq edit_Fin1 (get_tile "edit_Fin")) 
    (setq edit_Ins1 (get_tile "edit_Ins")) 
    (setq pop_ver (get_tile "pop_ver")) 
  ) 
  ;;6.3=============对话框驱动函数================== 
  (defun ConvDwgLst (/ DCLID FN FNAME LIN TOG_FIN1 X) 
    (setq fname (vl-filename-mktemp nil nil ".dcl")) 
    (setq fn (open fname "w")) 
    (write-line 
      "dcl_settings : default_dcl_settings { audit_level = 3; }" 
      fn 
    ) 
    (write-line "BatConVer : dialog {" fn) 
    (write-line "    label = "DWG批量处理<a href="http://bbs.mjtd.com/forum-6-1.html" target="_blank" class="relatedlink">工具</a>";" 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 
      "            : boxed_column{label = "文件选择";" 
      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 "            }" fn) 
    (write-line "            spacer;" fn) 
    (write-line 
      "            : boxed_column{label = "操作选择";" 
      fn 
    ) 
    (write-line "              : toggle {" fn) 
    (write-line "                label = "去教育版";" fn) 
    (write-line 
      "                key = "tog_del";                " 
      fn 
    ) 
    (write-line "              }" fn) 
    (write-line "              : toggle {" fn) 
    (write-line "                label = "版本转换";" fn) 
    (write-line "                value = "1";" fn) 
    (write-line "                key = "tog_con";" fn) 
    (write-line "              }" fn) 
    (write-line "              : toggle {" fn) 
    (write-line "                label = "减肥瘦身";" fn) 
    (write-line "                key = "tog_Wbl";" fn) 
    (write-line "              }" fn) 
    (write-line "            }" fn) 
    (write-line "            spacer;" fn) 
    (write-line 
      "            : boxed_column{label = "执行选择";" 
      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 "            }            " 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)[/align][align=left]    (setdata-1)    ;初始化对话框 
    (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 
      "tog_Fin" 
      "(setq tog_Fin1 $$value)(tog_FinDo tog_Fin1)" 
    ) 
    (action_tile 
      "tog_con" 
      "(setq tog_con1 $$value)(tog_conDo tog_con1)" 
    ) 
    (action_tile "but_OK" "(getdata-1)(done_dialog 1)") 
    (action_tile "but_Cancel" "(done_dialog 0)") 
    (setq return# (start_dialog)) 
    (unload_dialog dclid) 
    (close fn) 
    (vl-file-delete fname) 
    (if (and (= return# 1) (or(not (null dwgfileLst))(not (null HasOpenFiles)))) 
      (progn 
 (if (= TOG_WBL1 "1") 
   (progn (DwgWblock dwgfileLst) 
   (DwgWblock1 HasOpenFiles) 
   ) 
 ) 
 (if (= tog_del1 "1") 
   (progn (if dwgfileLst 
     (DelEduLog dwgfileLst) 
   ) 
   (if HasOpenFiles 
     (DelEduLog1 HasOpenFiles) 
   ) 
   ) 
 ) 
 (if (= tog_con1 "1") 
   (progn (DwgConverter POP_VER dwgfileLst) 
   (DwgConverter1 POP_VER HasOpenFiles) 
   ) 
 ) [/align][align=left]      ) 
    ) 
  )[/align][align=left]  ;;7===========定义容错函数=============== 
  (defun MyError (msg) 
    (if (or (= msg "Function cancelled") 
     (= msg "quit / exit abort") 
     (= msg "函数被取消") 
     (= msg "函数已取消") 
 ) 
      (princ) 
      (princ (strcat "\n 错误:" msg "\n")) 
    ) 
    (setvar "acadlspasdoc" HOLDLSP) 
    (princ) 
  )[/align][align=left]  ;;8=================dwg转dxf文件函数================ 
  (defun Dwg2Dxf (DwgName dxfName / AcadApp dbxDoc) 
    (setq AcadApp (vlax-get-acad-object) 
   dbxDoc  (vla-GetInterfaceObject 
      AcadApp 
      (GetObjectDBXVer) 
    ) 
    ) 
    (vla-open dbxDoc DwgName) 
    ;;(vla-saveas dbxDoc DwgName ac2000_dxf) 
    ;;(vla-close dbxDoc :vlax-false) 
    (vlax-invoke dbxDoc "dxfout" dxfName) 
     ;原来这句好好的，现在怎么不行了? 
    (if dbxDoc 
      (vlax-release-object dbxDoc) 
    )     ;关闭文档 
    (if AcadApp 
      (vlax-release-object AcadApp) 
    ) 
  )[/align][align=left]  ;;9.1==============非打开的文件版本转换================ 
  ;;DWGTYPE 对于本函数是全局 
  (defun DwgConverter (POP_VER   dwgfileLst /  ACADAPP 
         BASENAME   DOCOBJ     DWGNAME DWGVER 
         DXFFILE   FILEEXT    FILEPATH INDEX 
         NEWFILE 
        ) 
    ;;===从图元表中提取dxf组码值函数组码值函数 
    (defun dxf (Item dxfList) (cdr (assoc Item dxfList)))[/align][align=left]    (setq AcadApp (vlax-get-acad-object)) 
    (setq pop_ver (atoi pop_ver)) 
    (setq DwgVer (last (dxf pop_ver DwgType))) 
    (if (= (/ pop_ver 2) pop_ver) ;偶数 
      (setq FileExt ".dwg") 
      (setq FileExt ".dxf") 
    ) 
    (repeat (setq Index (length dwgfileLst)) 
      (setq DwgName  (nth (setq Index (1- 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) 
      ) 
      (setq DocObj (vla-open (vla-get-documents AcadApp) DwgName)) 
      (vla-saveas DocObj NewFile DwgVer) ;将原dwg文件存为指定版本的 
      (vla-close DocObj :vlax-false) 
      (if (= FileExt ".dxf") 
 (progn 
   ;;改为dwg同名文件 
   (if (findfile DxfFile) 
     (deletefile DxfFile) 
   ) 
   (vl-file-rename NewFile DxfFile) 
 ) 
 (progn 
   (deletefile DwgName) 
   ;;新保存的文件名改为原dwg文件名 
   (vl-file-rename NewFile DwgName) 
 ) 
      ) 
    )[/align][align=left]    (if DocObj 
      (vlax-release-object DocObj) 
    ) 
    (if AcadApp 
      (vlax-release-object AcadApp) 
    ) 
  ) 
  ;;9.2============已经打开的文件版本转换================ 
  (defun DwgConverter1 (POP_VER HasOpenFiles / *ACAD* *DOCS* DWGNAME N) 
    (setq *ACAD* (vlax-get-acad-object)) 
    ;;关闭 
    (repeat (setq n (length HasOpenFiles)) 
      (setq DwgName (nth (setq n (1- n)) HasOpenFiles)) 
      (vlax-for item (vla-get-Documents *ACAD*) 
 (if (= (strcase (vlax-get-property item 'FullName)) 
        (strcase DwgName) 
     ) 
   (vla-close item :vlax-false) 
 ) 
      ) 
    ) 
    ;;版本转换 
    (DwgConverter POP_VER HasOpenFiles) 
    ;;再打开 
    (setq *DOCS* (vla-get-documents *ACAD*)) 
    (repeat (setq n (length HasOpenFiles)) 
      (setq DwgName (nth (setq n (1- n)) HasOpenFiles)) 
      (vla-open *DOCS* DwgName) 
    ) 
  )[/align][align=left]  ;;10.1============非打开的文件去除教育版标记================ 
  (defun DelEduLog (dwgfileLst /   BACKUP     BACKUPFILE 
      BASENAME   AcadApp   DOCOBJ     DWGNAME 
      DXFEXT     DXFFILE   FILEPATH   INDEX 
     ) 
    (setq DxfExt ".dxf" 
   BackUp "_Backup" 
    ) 
    (setq AcadApp (vlax-get-acad-object)) 
    (repeat (setq Index (length dwgfileLst)) 
      (setq DwgName    (nth (setq Index (1- 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文件 
      (Dwg2Dxf DwgName dxfFile) 
      ;;备份文件存在，则删除 
      (if (findfile BackupFile) 
 (deletefile BackupFile) 
      ) 
      ;;修改原dwg文件为备份文件 
      (vl-file-rename DwgName BackupFile) 
      ;;打开dxf文件 
      (if (setq DocObj (vla-open (vla-get-documents AcadApp) dxfFile)) 
 (progn (deletefile BackupFile) 
        ;;再存为2000版dwg文件 
        (vla-saveas DocObj DwgName ac2000_dwg) 
        (vla-close DocObj :vlax-false) 
        ;;删除dxf文件 
        (deletefile dxfFile) 
 ) 
      ) 
    ) 
    (if DocObj 
      (vlax-release-object DocObj) 
    ) 
    (if AcadApp 
      (vlax-release-object AcadApp) 
    ) 
  ) 
  ;;10.2============已经打开的文件去除教育版标记================ 
  (defun DelEduLog1 (HasOpenFiles / *ACAD* *DOCS* DWGNAME N) 
    (setq *ACAD* (vlax-get-acad-object)) 
    ;;关闭 
    (repeat (setq n (length HasOpenFiles)) 
      (setq DwgName (nth (setq n (1- n)) HasOpenFiles)) 
      (vlax-for item (vla-get-Documents *ACAD*) 
 (if (= (strcase (vlax-get-property item 'FullName)) 
        (strcase DwgName) 
     ) 
   (vla-close item :vlax-false) 
 ) 
      ) 
    ) 
    ;;去除教育 
    (DelEduLog HasOpenFiles) 
    ;;再打开 
    (setq *DOCS* (vla-get-documents *ACAD*)) 
    (repeat (setq n (length HasOpenFiles)) 
      (setq DwgName (nth (setq n (1- n)) HasOpenFiles)) 
      (vla-open *DOCS* DwgName) 
    ) 
  ) 
  ;;11.1============非打开的文件减肥瘦身================ 
  (defun DwgWblock (dwgfileLst /   ACADAPP    BACKUPFILE 
      BASENAME   DOCOBJ   DWGNAME    FILEPATH 
      INDEX      NEWSET   SSETS 
     ) 
    (setq AcadApp (vlax-get-acad-object)) 
    (repeat (setq Index (length dwgfileLst)) 
      (setq DwgName (nth (setq Index (1- Index)) dwgfileLst)) 
      (setq BaseName   (vl-filename-base DwgName) 
     filepath   (vl-filename-directory DwgName) 
     ;;dxfFile    (vl-string-subst ".dxf" ".dwg" DwgName) 
     BackupFile (strcat (getfullpath filepath) 
          BaseName 
          "_Backup" 
          (vl-filename-extension DwgName) 
         ) 
      ) 
      (if (findfile BackupFile) 
 (deletefile BackupFile) 
      )     ;检查原dwg文件的备份文件名是否存在，如果存在，则删除 
      (if (vl-file-rename DwgName BackupFile) ;修改原dwg文件名 
 (progn 
   (setq 
     DocObj (vla-open (vla-get-documents AcadApp) BackupFile) 
   ) 
   (setq ssets (vla-get-selectionsets DocObj)) 
   (if (vl-catch-all-error-p 
  (vl-catch-all-apply 'vla-item (list ssets "$$Set")) 
       ) 
     (setq newSet (vla-add ssets "$$Set")) 
     (progn 
       (vla-delete (vla-item ssets "$$Set")) 
       (setq newSet (vla-add ssets "$$Set")) 
     ) 
   ) 
   ;;select all objects in the drawing 
   (vla-Select newSet acSelectionSetAll) 
   (vla-WBlock DocObj DwgName newSet) 
   (vla-close DocObj :vlax-false) 
   (deletefile BackupFile) 
 ) 
      ) 
    ) 
    (if DocObj 
      (vlax-release-object DocObj) 
    ) 
    (if AcadApp 
      (vlax-release-object AcadApp) 
    ) 
  ) 
  ;;11.2============已经打开的文件减肥瘦身================ 
  (defun DwgWblock1 (HasOpenFiles / *ACAD* *DOCS* DWGNAME N) 
    (setq *ACAD* (vlax-get-acad-object)) 
    ;;关闭 
    (setq HasOpenFiles (mapcar 'strcase HasOpenFiles)) 
    (vlax-for item (vla-get-Documents *ACAD*) 
      (if (member (strcase (vlax-get-property item 'FullName)) 
    HasOpenFiles 
   ) 
 (vla-close item :vlax-false) 
      ) 
    ) 
    ;;减肥瘦身 
    (DwgWblock HasOpenFiles) 
    ;;再打开 
    (setq *DOCS* (vla-get-documents *ACAD*)) 
    (repeat (setq n (length HasOpenFiles)) ;使用foreach失败，原因待查 
      (setq DwgName (nth (setq n (1- n)) HasOpenFiles)) 
      (vla-open *DOCS* DwgName) 
    ) 
  ) 
  ;;15=================主函数=========== 
  (setq OldError *error* 
 *error*  MyError 
 HOLDLSP  (getvar "ACADLSPASDOC") 
  ) 
  (setvar "acadlspasdoc" 0) 
  (setvar "cmdecho" 0) 
  ;;(if (not MsgBox)(load "MsgBox"))[/align][align=left]  (cond 
    ((< (atof (getvar "acadver")) 16) ;检查版本 
     ;|(MsgBox "版本检查" 
      64 
      "此程序只能运行在AutoCAD 2004或更高版本!" 
     )|; 
     (alert "此程序只能运行在AutoCAD 2004或更高版本!") 
     (exit) 
    ) 
    ((/= 1 (getvar "dwgtitled")) ;未保存过的文件 
     ;;(setq dcl_id (load_dialog "dwgconverter")) 
     (setq Initdir (getvar "dwgprefix")) 
     (ConvDwgLst) 
    ) 
    ((= 1 (getvar "dwgtitled"))  ;文件环境(保存过) 
     ;|(MsgBox 
       "使用环境检查" 
       64 
       "批量处理只能在新建且未保存的文件中运行!\n\n当前文档未必能成功去除教育版印戳!" 
     )|; 
     (alert 
       "批量处理只能在新建且未保存的文件中运行!\n\n当前文档未必能成功去除教育版印戳!" 
     ) 
     (if (setq EduPlotSt (findfile "EduPlotStamp.exe")) 
       (startapp EduPlotSt) 
     ) 
    ) 
  ) 
  ;;(setvar "acadlspasdoc" HOLDLSP) 
  (setq *error* OldError) 
  (gc) 
  (princ) 
)[/align][align=left] 
;;==============================公用函数==========================[/align][align=left];;1 =============获取全路径，即路径后有\================================= 
(defun GetFullPath (path) 
  (if (wcmatch path "*\") 
    path 
    (strcat path "\") 
  ) 
)[/align][align=left];;2 ============================获取文件夹程序================================= 
;;根据Express tools是否安装决定使用哪一个函数 
(defun GetFolderNew (InitDir msg / ArxFile Apptitle) 
  (setq Apptitle "浏览文件夹" 
 ArxFile  "acetutil.arx" 
  ) 
  (if (findfile ArxFile) 
    (GetFolder3 Apptitle Msg InitDir) 
    (getFolder1 msg) 
  ) 
) 
;;2.1 没有安装ET时选择的文件夹 
;;来自于明经秋枫 
;; 用法：(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) 
  ) 
) 
;;2.2 安装ET后选择的文件夹 
(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) 
  ) 
)[/align][align=left];;3 ============;;注册"MSComDlg.CommonDialog"============================= 
(defun Regdlg () 
  (vl-registry-write 
    "HKEY_CLASSES_ROOT\\LICENSES\\4d553650-6abe-11cf-8adb-00aa00c00905" 
    "" 
    "gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj" 
  ) 
)[/align][align=left];;4 ============将输入的数据转换为字符串列表=================== 
(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))) 
    ) 
  ) 
)[/align][align=left];;5.1 =============获取指定文件夹(不包括子文件夹)下所有满足扩展名的文件=========== 
;;返回列表文件表元素全为小写 
(defun GetAllSpecFilesInFolder (dir filter) 
  (mapcar 
    (function 
      (lambda (file) 
 (strcase (strcat (getfullpath dir) file) T) 
      ) 
    ) 
    (vl-directory-files dir filter 1) 
  ) 
) 
;;5.2 =============获取指定文件夹(包括子文件夹)下所有满足扩展名的文件=========== 
(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 
)[/align][align=left] ;|;定义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[/align][align=left];;7 =========获取ObjectDBX版本字符串============ 
(defun GetObjectDBXVer (/ VERSION) 
  (if (>= (setq VERSION (atoi (getvar "acadver"))) 16) 
    (strcat "ObjectDBX.AxDbDocument." (itoa VERSION)) 
  ) 
)[/align][align=left];;8 =================删除文件函数=================== 
;; 能删除所有文件，不管只读、隐藏与否，都能删除 
;; 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) 
)[/align][align=left];;9 生成表记录函数：把字符串变为表 
(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)) 
    ) 
  ) 
)[/align][align=left];;10 添加分隔符函数 
(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) 
)

ORCHI · 发表于 2013-1-18 20:27:36

谢谢楼主，最关注去教育版功能，希望好用。

nyistjz · 发表于 2021-12-8 15:58:04

这个源码复制后，格式有变化，您是否可以把LSP以附件的形式再发一下？

wu0146 · 发表于 2022-4-25 17:53:18

查找替换以后，原文件名称包含大小写的最后全部变成了小写

自贡黄明儒 · 发表于 2013-1-18 19:20:45

本帖最后由自贡黄明儒于 2013-1-18 19:29 编辑

界面如下：

yzr2002626 · 发表于 2013-1-18 19:47:13

顶个先,试用看OK不

bdboy · 发表于 2013-1-18 20:02:10

本帖最后由 bdboy 于 2013-1-18 20:02 编辑

谢谢了.....试试

SunSpring · 发表于 2013-1-18 20:14:05

支持,谢谢楼主.

yjr111 · 发表于 2013-1-18 20:18:02

我最喜欢去教育版了，论坛这么多，我一个都用不了，看看黄兄大作

yjr111 · 发表于 2013-1-18 20:23:32

用不了~~~~~~~~~~~

kwok · 发表于 2013-1-18 20:24:23

顶,支持一下,现在很少有教育版吧.

smartstar · 发表于 2013-1-18 20:31:38

向楼主学习学习。

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

[讨论] DWG批量去教育版/版本转换/减肥瘦身/查找替换

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

相关帖子

本帖子中包含更多资源

本帖子中包含更多资源