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 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