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