本帖最后由 自贡黄明儒 于 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)
- )
|