@H_403_0@Option Explicit '//*********************************************************************** '//类模块名称：ClsCompactDatabase '//版权所有：米特仪表有限公司 版权所有 '//开发作者：段利庆(Lee) '// QQ:14035344 '// http://www.duanliqing.kudo.cn '// http://leek.woku.com '//创建日期：2010-07-28 '//功能描述：处理数据库文件备份 '// 备注：引用 Microsoft Jet and Replication Objects X.X library，其中 ( X.X 大于或等于 2.1 )。 '//*********************************************************************** '*系统临时文件夹路径 Private Declare Function GetTempPath Lib "kernel32" Alias _ "GetTempPathA" (ByVal nBufferLength As Long,ByVal lpBuffer As String) As Long Private Sub ErrMessage(ByVal Procedure As String,_ Optional ByVal AffErrMsg As String) '' ========================================================== ' 开发人员：段利庆 ' 编写时间：2009-02-01 ' 过程名称：ErrMessage ' 参数说明：Procedure 过程或函数的名称 ' 可选参数：AffErrMsg 附加说明的错误消息提示文本 ' ' 功能说明：类模块内使用的错误消息，功能便于跟踪错误的来源 '' ========================================================== Dim strMsg As String strMsg = strMsg & strMsg strMsg = strMsg & " ErrNumber: " & Err.Number & vbCrLf strMsg = strMsg & "ErrDescription: " & Err.Description & vbCrLf If Len(AffErrMsg) <> 0 Then strMsg = strMsg & " AffErrMsg: " & AffErrMsg & vbCrLf End If '*空一行 strMsg = strMsg & " " & vbCrLf '*类模块的名称 strMsg = strMsg & " Module: " & "ClsBin" & vbCrLf strMsg = strMsg & " Procedure: " & Procedure & vbCrLf '*空一行 strMsg = strMsg & " " & vbCrLf strMsg = strMsg & "Please notify My Software's tech support " & vbCrLf strMsg = strMsg & "at QQ:14035344 about this issue." & vbCrLf strMsg = strMsg & "Please E-mail to lee_software@sohu.com.cn " & vbCrLf strMsg = strMsg & "Please provide the support technician with " & vbCrLf strMsg = strMsg & "information shown in this dialog " & vbCrLf strMsg = strMsg & "Box as well as an explanation of what you were" & vbCrLf strMsg = strMsg & "doing when this error occurred." & vbCrLf MsgBox strMsg,vbCritical,"ClsCompactDatabase" Err.Clear End Sub '*获得系统临时文件夹路径 '*仅给压缩数据库用 Private Function subGetTemporaryPath() Const MAX_PATH = 260 Dim strFolder As String Dim lngResult As Long strFolder = String(MAX_PATH,0) lngResult = GetTempPath(MAX_PATH,strFolder) If lngResult <> 0 Then subGetTemporaryPath = Left(strFolder,InStr(strFolder,Chr(0)) - 1) Else subGetTemporaryPath = "" End If End Function Public Sub subCompactJetDatabase(Location As String,Optional BackupOriginal As Boolean = True) '' ========================================================== ' 开发人员：段利庆 ' 编写时间：10-07-28 ' 过程名称：subCompactJetDatabase ' 参数说明：Location 数据库文件所在目录 ' BackupOriginal 是否需要备份数据库 ' ' 功能说明：压缩数据库，去除数据库操作产生的冗于 ' 注意：必须应用DAO的<DBEngine>对象 '' ========================================================== On Error GoTo CompactErr Dim strBackupFile As String Dim strTempFile As String '检查数据库文件是否存在 If Len(Dir(Location)) Then ' 如果需要备份就执行备份 If BackupOriginal = True Then strBackupFile = subGetTemporaryPath & "backup.mdb" If Len(Dir(strBackupFile)) Then Kill strBackupFile FileCopy Location,strBackupFile End If ' 创建临时文件名 strTempFile = subGetTemporaryPath & "temp.mdb" If Len(Dir(strTempFile)) Then Kill strTempFile Dim jro As jro.JetEngine Set jro = New jro.JetEngine '來源文件 jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Location & ";Jet OLEDB:Database Password=duan",_ "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strTempFile '压缩后生成tempDB.mdb ' 删除原来的数据库文件 Kill Location ' 拷贝刚刚压缩过临时数据库文件至原来位置 FileCopy strTempFile,Location ' 删除临时文件 Kill strTempFile Else End If MsgBox "数据库压缩完毕！",vbOKOnly + vbExclamation Exit Sub CompactErr: Dim sAffErrMsg As String sAffErrMsg = "数据库打开时不能压缩！请退出程序重试！" Call ErrMessage("subCompactJetDatabase",sAffErrMsg) End Sub 程序设计：段利庆（Lee） QQ；14035344