DWG批量去教育版/版本转换/减肥瘦身/查找替换
本帖最后由 自贡黄明儒 于 2013-11-11 13:16 编辑1 前言：我最喜欢批量处理东西了，比如给圆和封闭多边形加中心线、文字对齐。。。2 说明：2.1 本程序用vl编写2.2 从iceberg2509 的批量去教育版/版本转换一贴，可以学到许多实用的东西，可我一直没有将此派上用场，原因是要2010版本才能使用；已经打开的文件不能处理。2.3 批量文字查找替换，有一个被雪山飞狐加精的帖子，可惜是VB版的。2.4 我试图将上面功能弄成一个界面，想想也就算了，麻烦，能用就行了。3 命令：outMyFind4 功能：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_SUBFOLDERTOG_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)
)
)
);;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)
) (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
HASOPENFILESN 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)
);;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)
(setqflags(+ 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
);;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)
);;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) (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)
)
) )
)
);;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)
);;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)
)
);;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))) (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)
)
)
) (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)
)
);;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"))(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)
)
;;==============================公用函数==========================;;1 =============获取全路径，即路径后有\=================================
(defun GetFullPath (path)
(if (wcmatch path "*\\")
path
(strcat path "\\")
)
);;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)
)
);;3 ============;;注册"MSComDlg.CommonDialog"=============================
(defun Regdlg ()
(vl-registry-write
"HKEY_CLASSES_ROOT\\LICENSES\\4d553650-6abe-11cf-8adb-00aa00c00905"
""
"gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj"
)
);;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)))
)
)
);;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
) ;|;定义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 vbExclamation48
vbInformation64
vbDefaultButton10
vbDefaultButton2256
vbDefaultButton3512
vbDefaultButton4768
vbApplicationModal 0
vbSystemModal4096
)
;;返回值
;;1OK button
;;2Cancel button
;;3Abort button
;;4Retry button
;;5Ignore button
;;6Yes button
;;7No 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;;7 =========获取ObjectDBX版本字符串============
(defun GetObjectDBXVer (/ VERSION)
(if (>= (setq VERSION (atoi (getvar "acadver"))) 16)
(strcat "ObjectDBX.AxDbDocument." (itoa VERSION))
)
);;8 =================删除文件函数===================
;; 能删除所有文件，不管只读、隐藏与否，都能删除
;; vl-file-delete不能删除只读文件
;;Scripting.FileSystemObject格式
;;fso.DeleteFile ( filespec[, force] )
;;参数
;; fso必选项, 应为 FileSystemObject 的名称。
;; filespec 必选项, 要删除的文件的名称,filespec 可以在最后的路径成分中包含通配字符。
;; force 可选项, Boolean 值，如果要删除设置了只读属性的文件，则为 true ；如果不删除则为 false （默认）。
;; Arguments :
;; Fil = FileName, "C:\\test\\Autoexec.bat"
;; 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)
);;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))
)
)
);;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)
)
谢谢楼主，最关注去教育版功能，希望好用。 这个源码复制后，格式有变化，您是否可以把LSP以附件的形式再发一下？ 查找替换以后，原文件名称包含大小写的最后全部变成了小写 本帖最后由 自贡黄明儒 于 2013-1-18 19:29 编辑
界面如下：
顶个先,试用看OK不 本帖最后由 bdboy 于 2013-1-18 20:02 编辑
谢谢了.....试试 支持,谢谢楼主. 我最喜欢去教育版了，论坛这么多，我一个都用不了，看看黄兄大作 用不了~~~~~~~~~~~
顶,支持一下,现在很少有教育版吧. 向楼主学习学习。