iT邦幫忙

2017 iT 邦幫忙鐵人賽
DAY 30
1
自我挑戰組

Access VBA的眉眉角角系列 第 30

Access VBA 的眉眉角角Day30: MDB檔案備份

上一篇我們提到使用VBA來備份與還原物件,這一篇來點不同的作法,將整個MDB檔案備份,這部份牽扯到了單純備份MDB檔案,還是將外部資料庫的資料表也複製到MDB中,由於筆者有此需求,所以另外撰寫了這個選項,讓程式執行備份時,轉出近期資料於備份的MDB檔中,讓該MDB檔案,包含了近期的資料,可以用於非公司內部網路的使用者,查詢到近期資料。
當然,除了提供資料給同仁參考外,也可以當作備份的一種方式,外部SQL Server的資料,並不保證不出問題,若之後有出問題,手邊還有另一備份可以使用,會更有保障。
另外,壓縮的部份,筆者選用WinRAR來進行壓縮,若有朋友喜歡用7z的,也可以試著製作相關的子程式使用,筆者這邊會用到Day15提到的WinRAR壓縮子程式處理壓縮程序。
MDB檔案的保存,還有另一個需要注意的,由於操作Access來產資料時,有時候會造成MDB檔案日益肥大,雖然可以由「工具」->「資料庫公用程式」->「壓縮與修復資料庫」的功能,壓縮與修復MDB檔案,但如果可以透過VBA來操作,將會更簡便:
http://ithelp.ithome.com.tw/upload/images/20161229/20007221N8zvXcfDdG.png

這裡我先列出此子程式,因為後面程式會運用到:

Sub MDB_CompactAndRepair(strSourceDB As String, _
                         Optional strPassword As String = "", _
                         Optional bnDoRARBackup As Boolean = False _
                         )
'Compact and repair the MDB file.
'strSourceDB 來源資料
'strPassword MDB密碼
'bnDoRARBackup 是否先以RAR備份

Set oEngine = CreateObject("JRO.JetEngine")

Dim strDestDB As String, strBackDB As String

strDestDB = strSourceDB & "_new.mdb"
strBackDB = strSourceDB & ".rar"

oEngine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                "Data Source=" & strSourceDB & ";" & _
                                "Jet OLEDB:Database Password=" & strPassword & ";", _
                                "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                "Jet OLEDB:Engine Type=5;" & _
                                "Data Source=" & strDestDB & ";" & _
                                "Jet OLEDB:Database Password=" & strPassword & ";"
                                
If bnDoRARBackup = True Then
    Call WinRAR("m", strBackDB, strSourceDB, "", "")
Else
    Kill strSourceDB
End If

Name strDestDB As strSourceDB

End Sub

此程式可以壓縮本身MDB檔案以外的MDB檔,所以如果要壓縮本身的MDB檔,還是須透過功能選項來壓縮,但可喜的是,我們要轉出資料給user用,或者轉出資料來備份,這就是本身以外的MDB檔,即可透過此程式來處理。

以下程式為轉出MDB檔案的主程式:

Function ExpMDBData(Optional bnSilence As Boolean = False, _
                    Optional strDestFullPathFileName As String = "", _
                    Optional strWinRAR2ServerPath As String = "", _
                    Optional bnShowResult As Boolean = True, _
                    Optional bnExpTableData As Boolean = True, _
                    Optional strRARFileName As String = "MDBS-Data.rar", _
                    Optional bnDeleteSecretData As Boolean = True, _
                    Optional dateWorkMonth As Date = "1990/1/1", _
                    Optional dateWorkMonthStart As Date, _
                    Optional dateWorkMonthEnd As Date, _
                    Optional strRARFileSaveLocal As String = "D:\MDBS_Backup", _
                    Optional strRARFileSaveNameLocal As String = "MDBS-Data", _
                    Optional bnMDBCompactAndRepair As Boolean = True _
                    )
                    
'bnSilence               安靜模式,不秀出任何訊息
'strDestFullPathFileName 目的地完整路徑與檔名
'strWinRAR2ServerPath    使用WinRAR備份的目的地路徑(有填寫此項目,才會進行壓縮)
'bnShowResult            顯示結果
'bnExpTableData          是否匯出外部資料表
'strRARFileName          WinRAR備份的檔名
'bnDeleteSecretData      刪除敏感資料
'dateWorkMonth           外部資料表指定匯出月份
'dateWorkMonthStart      外部資料表指定匯出月份起始
'dateWorkMonthEnd        外部資料表指定匯出月份結束
'strRARFileSaveLocal     本機壓縮檔存放路徑
'strRARFileSaveNameLocal 本機壓縮檔存放檔名
'bnMDBCompactAndRepair   是否執行MDB壓縮與修復

Dim strDateStamp  As String, strCmd As String
Dim strSQL As String
 
'If Config("MasterPcName") <> Environ("COMPUTERNAME") Then Exit Sub

If bnSilence = False Then
    If MsgBox("執行匯出備份?", vbOKCancel) <> vbOK Then Exit Function
End If

dateStart = Now

'若沒有指定路徑,則填入預設路徑
If strDestFullPathFileName = "" Then
    strDestFullPathFileName = CurrentProject.path & "\" & CurrentProject.Name & "_Backup.mdb"
End If

'複製MDB檔到指定位置
Set fso = CreateObject("scripting.filesystemobject")
fso.CopyFile Source:=CurrentDb.Name, Destination:=strDestFullPathFileName

'是否刪除敏感資料
If bnDeleteSecretData = True Then
    '清除電子郵件密碼
    strSQL = "SELECT * FROM Config IN '" & strDestFullPathFileName & "' WHERE Name='e-mail_sendpassword'"
    Set m = CurrentDb.OpenRecordset(strSQL)
    m.Edit
    m("Value") = ""
    m.Update
    
    ''清除AS400資料表清單
    strSQL = "DELETE * FROM AS400LIBFILEFFDH IN '" & strDestFullPathFileName & "'"
    Call RunSQL(strSQL)
    strSQL = "DELETE * FROM AS400LIBFILEFFDB IN '" & strDestFullPathFileName & "'"
    Call RunSQL(strSQL)
    
    '清除連線資料表描述
    strSQL = "UPDATE ConnectTables IN '" & strDestFullPathFileName & "' SET DESCRIPTION = ''; "
    Call RunSQL(strSQL)
End If


'如果需要轉出外部資料表(SQLServer)
If bnExpTableData = True Then

    '看是否有設定起始與結束月份資料
    '沒有的話進行設定
    If CDbl(dateWorkMonthStart) > 0 And CDbl(dateWorkMonthStart) > 0 Then
    
    ElseIf dateWorkMonth > "1990/1/1" Then
        dateWorkMonthStart = DateAdd("d", (Day(dateWorkMonth) - 1) * -1, dateWorkMonth)
        dateWorkMonthEnd = DateAdd("d", -1, DateAdd("m", 1, DateAdd("d", (Day(dateWorkMonth) - 1) * -1, dateWorkMonth)))
    Else
        dateWorkMonthStart = "1990/1/1"
        dateWorkMonthEnd = "3000/1/1"
    End If

    strSQL = "SELECT * FROM ConnectTables WHERE ConnectTables.SERVER_TYPE='SQLServer'"
    Set m = CurrentDb.OpenRecordset(strSQL)
    If m.EOF = True Then Exit Function
    Do
        '如果有設定起始日期,則填入strWHERE字串中
        strWHERE = ""
        If dateWorkMonthStart <> "1990/1/1" Then
            If m("EXP_DATE_RANGE") = 1 Then
               strStart = Format(dateWorkMonthStart, "YYYYMMDD")
               strEnd = Format(dateWorkMonthEnd, "YYYYMMDD")
               strStartDate = Format(dateWorkMonthStart, "MM/DD/YYYY")
               strEndDate = Format(dateWorkMonthEnd, "MM/DD/YYYY")
            
            ElseIf IsNull(m("EXP_DATE_RANGE")) Then
               strStart = "00000000"
               strEnd = "99999999"
               strStartDate = "1000/1/1"
               strEndDate = "3000/1/1"
            Else
               dateWorkMonthStart2 = DateAdd("m", (m("EXP_DATE_RANGE") - 1) * -1, DateAdd("d", (Day(dateWorkMonth) - 1) * -1, dateWorkMonth))
        
               strStart = Format(dateWorkMonthStart2, "YYYYMMDD")
               strEnd = Format(dateWorkMonthEnd, "YYYYMMDD")
               strStartDate = Format(dateWorkMonthStart2, "MM/DD/YYYY")
               strEndDate = Format(dateWorkMonthEnd, "MM/DD/YYYY")
            
            End If
            
            If m("EXP_DATE_FIELD_TYPE") = "TEXT" Then
                strWHERE = "WHERE " & m("EXP_DATE_FIELD") & " BETWEEN '" & strStart & "' AND '" & strEnd & "'"
            ElseIf m("EXP_DATE_FIELD_TYPE") = "DATE" Then
                strWHERE = "WHERE " & m("EXP_DATE_FIELD") & " BETWEEN #" & strStartDate & "# AND #" & strEndDate & "# "
            ElseIf m("EXP_DATE_FIELD_TYPE") = "NUMBER" Then
                strWHERE = "WHERE " & m("EXP_DATE_FIELD") & " BETWEEN " & strStart & " AND " & strEnd & " "
            End If
        
        End If
        
        '如果有JOIN_STRING字串,則填入strJOIN
        If m("JOIN_STRING") <> "" Or IsNull(m("JOIN_STRING")) = False Then
            strJOIN = m("JOIN_STRING")
        Else
            strJOIN = ""
        End If
        
        strSQL = "SELECT * INTO " & m("LOCAL_TABLE") & " IN '" & strDestFullPathFileName & "' " & _
                 "FROM " & m("LOCAL_TABLE") & " " & strJOIN & " " & _
                 strWHERE & "; "
                 
        'strSQL = "SELECT * INTO " & M("LOCAL_TABLE") & " IN '" & strDestFullPathFileName & "' " & _
        "FROM " & M("LOCAL_TABLE") & "; "
        Call RunSQL(strSQL)
        m.MoveNext
    Loop Until m.EOF = True
    
End If

Set m = Nothing

'進行MDB壓縮
If bnMDBCompactAndRepair = True Then
    Call MDB_CompactAndRepair(strDestFullPathFileName)
End If


'如果有WinRAR壓縮檔存放路徑,則建立壓縮檔
If Len(strWinRAR2ServerPath) > 0 Then
    Dim strDes As String, strSrc As String
    If Right(strWinRAR2ServerPath, 1) <> "\" Then strWinRAR2ServerPath = strWinRAR2ServerPath & "\"
    strDateStamp = Format(Now, "yyyy-MM-dd-HHmmss")
    strDes = strRARFileSaveLocal & "\" & strRARFileSaveNameLocal & "_" & strDateStamp & ".rar"
    strSrc = strDestFullPathFileName
    
    '先壓縮在本地磁碟機
    Call WinRAR("a", strDes, strSrc, "", "")
    'Sleep 10000
    '然後再複製到指定位置
    FileCopy strDes, strWinRAR2ServerPath & strRARFileName
End If

'計算作業時間
dateUse = Now - dateStart
If bnShowResult = True And Len(strWinRAR2ServerPath) > 0 Then
    MsgBox "Done!" & vbCrLf & vbCrLf & _
           "儲存檔案:" & strDestFullPathFileName & vbCrLf & _
           "壓縮檔案:" & strWinRAR2ServerPath & strRARFileName & vbCrLf & _
           "使用時間:" & Format(dateUse, "HH:MM:SS")
ElseIf bnShowResult = True Then
    MsgBox "Done!" & vbCrLf & vbCrLf & vbCrLf & _
           "儲存檔案:" & strDestFullPathFileName & vbCrLf & _
           "使用時間:" & Format(dateUse, "HH:MM:SS")
End If

End Function

此程式中,運用了Access SQL的IN語法,讓SQL語句可以直接操控外部的MDB檔案,以此方式來清理敏感資料,讓user拿到時,是已經整理過的MDB檔案。
轉出外部資料表的部份,使用了Day28提到的ConnectTables資料表,裡面有記載外部資料轉出時,要抓取什麼範圍內的數據,以便轉出時僅部份新資料,避免MDB檔過大。
以此方式,可以保存最完整的MDB資料,而上篇則是透過轉出純文字檔,來達到批次修改與使用GitHub管理的效果,跟本篇的需求有所區隔。
物件轉移的部份,其實透過Access使用「匯入」方式直接操作會更便利,當然,轉成純文字檔後,有使用VBA操控的優勢,達到自動化的效果,這又是另一種思考邏輯了。

以下為測試程式:

Sub ExpMDBData測試()
    Call ExpMDBData(False, CurrentProject.path & "\" & CurrentProject.Name & "_匯出測試.mdb", _
                    CurrentProject.path, True, False, CurrentProject.Name & ".rar", False, , , , Environ("TEMP"), "TEST")
    
End Sub

執行後,出現是否備份,按「確定」繼續:
http://ithelp.ithome.com.tw/upload/images/20161229/20007221XLWvAp7pTJ.png

完成後,會列出相關檔案與使用時間:
http://ithelp.ithome.com.tw/upload/images/20161229/20007221tAoeWcfJwV.png

最後於資料夾內,可以找到相關檔案:
http://ithelp.ithome.com.tw/upload/images/20161229/200072211ohZVynAaN.png


很快的,30天已經到來,筆者將近年所學分享出來,希望對有心學習的邦友們有所助益。
這30天整理手邊相關的程式碼,越整理,越覺得自己所學還是有所欠缺,透過這些時間的沈澱與精粹,越能知道自己的方向與目標,雖然Access年華已老,已跟不上時代的腳步,但其實會抓老鼠的貓就是好貓,能開闢山路的就是好刀,不需要用老虎來抓老鼠,也不需要推土機來開山路,這些程式老兵,在某些角落,還是有一片天的。

以下為此次有用到的相關程式碼與範例,有興趣者可以取回參考。

Access VBA的眉眉角角.rar


上一篇
Access VBA 的眉眉角角Day29: 物件的存取
系列文
Access VBA的眉眉角角30

2 則留言

0
牛哥
iT邦好手 1 級 ‧ 2017-01-01 18:21:38

長知識,讚!
新年快樂!!

Andy Chiu iT邦研究生 3 級 ‧ 2017-01-01 20:20:05 檢舉

謝謝啦!也祝 新年快樂 萬事如意!

0
oxxo
iT邦研究生 2 級 ‧ 2017-01-13 22:18:58

恭喜完賽 ^_^

Andy Chiu iT邦研究生 3 級 ‧ 2017-01-14 10:40:38 檢舉

/images/emoticon/emoticon07.gif

我要留言

立即登入留言