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