VB使用ADOX压缩修复ACCESS数据库文件的类模块

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 LongPrivate 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 [e-mail] " & 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 IfEnd FunctionPublic 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 + vbExclamationExit SubCompactErr: Dim sAffErrMsg As String sAffErrMsg = "数据库打开时不能压缩！请退出程序重试！" Call ErrMessage("subCompactJetDatabase", sAffErrMsg)End Sub

 

 

程序设计：段利庆（Lee） QQ；14035344