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