iT邦幫忙

2019 iT 邦幫忙鐵人賽

DAY 29
0
自我挑戰組

Access VBA 之 iT管理實做系列 第 29

Access VBA 之 iT管理實做Day29: XML資料的收集

XML資料的處理,在Access上算是有支援的,只是要用VBA來撰寫程式時,還是得靠微軟的XML DOM物件來開發,使用上,可以使用設定引用項目的方式,或者使用CreateObject("MSXML2.DOMDocument")的方式來處理。
筆者主要是用來處理SOAP的資料,進行電子簽證蓋章的作業,但這部份功能就比較單一,拿出來分享的話,也很難應用到其他地方,所以我另外找了些資料來進行示範。

政府資料開放平臺資料集清單:
https://data.gov.tw/dataset/6564

這裡可以下載到政府的開放資料清單,檔案很大,不過資料結構很單一,我們先透過DDL建立欄位清單,

CREATE TABLE Dataset_DataGovTW (
[資料集識別碼] LONG,
[資料集名稱] TEXT (255),
[檔案格式] MEMO,
[資料下載網址] MEMO,
[資料集類型] TEXT (255),
[資料集描述] MEMO,
[主要欄位說明] MEMO,
[提供機關] TEXT (255),
[更新頻率] TEXT (255),
[授權方式] TEXT (255),
[計費方式] TEXT (255),
[編碼格式] MEMO,
[提供機關聯絡人姓名] TEXT (255),
[提供機關聯絡人電話] TEXT (255),
[備註] MEMO,
[意見樣態類型] MEMO)

然後使用以下程式碼來進行解析與匯入的動作:

筆數有3萬7千多筆,資料蠻大的,待資料表建立後,可以使用以下程式進行匯入:

Sub ImportXML2MDB()
    Dim strURL As String
    Dim XDoc As Object, root As Object, listNode As Object
     
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False: XDoc.validateOnParse = False
    
    strAns = MsgBox("從網路下載或者指定檔案?[是]由網路下載,[否]指定檔案位置,[取消]取消作業。", vbYesNoCancel)
    
    If strAns = vbYes Then
        '政府資料開放平臺資料集清單
        MsgBox "下載與匯入時間花費較長,請耐心等候!"
        strURL = "https://data.gov.tw/datasets/export/xml"
        res = GetResult(strURL)
        'Debug.Print res
        XDoc.LoadXML res
        
    ElseIf strAns = vbNo Then
        strURL = SelectFile("", "*.xml")
        If isNothing(strURL) Then Exit Sub
        MsgBox "匯入需耗費時間,請耐心等候!"
        XDoc.Load strURL
    Else
        Exit Sub
    End If
    
    Set root = XDoc.DocumentElement
    
    Set m = CurrentDb.OpenRecordset("SELECT * FROM Dataset_DataGovTW ")

    For Each listNode In root.ChildNodes
        m.AddNew
        Debug.Print "[" & listNode.FirstChild.BaseName & "] = [" & listNode.FirstChild.text & "]"
        For Each fieldNode In listNode.ChildNodes
            'Debug.Print "[" & fieldNode.BaseName & "] = [" & fieldNode.text & "]"
            m(fieldNode.BaseName) = fieldNode.text
            
        Next fieldNode
        m.Update
    Next listNode
    
End Sub

需要以下子程式:

下載檔案:

Function GetResult(url As String) As String
    '取得網頁內容
    Dim XMLHTTP As Object, ret As String
    Set XMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    XMLHTTP.Open "GET", url, False
    XMLHTTP.setRequestHeader "Content-Type", "text/xml"
    XMLHTTP.setRequestHeader "Cache-Control", "no-cache"
    XMLHTTP.setRequestHeader "Pragma", "no-cache"
    XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
    XMLHTTP.send
    ret = XMLHTTP.ResponseText
    GetResult = ret
End Function

選擇檔案,這部份由之前「Excel VBA的眉眉角角」改寫而來,如果偵測到SelectFile無法使用,則改用ChooseFile,主要是Windows 7之後不再支援使用CreateObject("MSComDlg.CommonDialog")方式來選擇檔案:

Public Function SelectFile(strPath As String, strFileType As String) As String
Dim a As Object
On Error GoTo ErrZone:
Set a = CreateObject("MSComDlg.CommonDialog")


If Right(strPath, 1) = "\" Then
    a.fileName = strPath & strFileType '指定副檔名...不果不限則改用 *.*
Else
    a.fileName = strPath & "\" & strFileType '指定副檔名...不果不限則改用 *.*
End If

a.ShowOpen

If Right(a.fileName, 3) = "*.*" Then
    SelectFile = ""
Else
    SelectFile = a.fileName
End If

Exit Function

ErrZone:
Debug.Print err.Number & ": " & err.DESCRIPTION
If err.Number = 429 Then
    'SelectFile = fBrowseForFile2(strPath, strFileType & "," & strFileType)
    SelectFile = ChooseFile(strPath, "(" & strFileType & ")|" & strFileType)
End If

End Function

Function ChooseFile(ByVal initialDir, Optional strFilter = "All Files|*.*")
    '使用powershell來選擇檔案
    'http://todayguesswhat.blogspot.mx/2012/08/windows-7-replacement-for.html
    Dim objShell As Object, fso As Object, tempDir As String, tempFile As String
    Dim powershellFile As String, powershellOutputFile As String, psScript As String
    Dim textFile As Object
    
    Set objShell = CreateObject("WScript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")
    tempDir = objShell.ExpandEnvironmentStrings("%TEMP%")
    tempFile = tempDir & "\" & fso.GetTempName
    
    '將分隔標示改為| "," -> "|"
    strFilter = Replace(strFilter, ",", "|")
    
    ' temporary powershell script file to be invoked
    powershellFile = tempFile & ".ps1"
    
    ' temporary file to store standard output from command
    powershellOutputFile = tempFile & ".txt"

    'input script
    psScript = psScript & "[System.Reflection.Assembly]::LoadWithPartialName(""System.windows.forms"") | Out-Null" & vbCrLf
    psScript = psScript & "$dlg = New-Object System.Windows.Forms.OpenFileDialog" & vbCrLf
    psScript = psScript & "$dlg.initialDirectory = """ & initialDir & """" & vbCrLf
    psScript = psScript & "$dlg.filter = """ & strFilter & """" & vbCrLf
    ' filter index 4 would show all files by default
    ' filter index 1 would should zip files by default
    psScript = psScript & "$dlg.FilterIndex = 4" & vbCrLf
    psScript = psScript & "$dlg.Title = ""Select a file to upload""" & vbCrLf
    psScript = psScript & "$dlg.ShowHelp = $True" & vbCrLf
    psScript = psScript & "$dlg.ShowDialog() | Out-Null" & vbCrLf
    psScript = psScript & "Set-Content """ & powershellOutputFile & """ $dlg.FileName" & vbCrLf
    'MsgBox psScript
    
    Set textFile = fso.CreateTextFile(powershellFile, True)
    textFile.WriteLine (psScript)
    textFile.Close
    Set textFile = Nothing
    
    ' objShell.Run (strCommand, [intWindowStyle], [bWaitOnReturn])
    ' 0 Hide the window and activate another window.
    ' bWaitOnReturn set to TRUE - indicating script should wait for the program
    ' to finish executing before continuing to the next statement
    
    Dim appCmd
    appCmd = "powershell -ExecutionPolicy unrestricted &'" & powershellFile & "'"
    'MsgBox appCmd
    objShell.Run appCmd, 0, True
    
    ' open file for reading, do not create if missing, using system default format
    Set textFile = fso.OpenTextFile(powershellOutputFile, 1, 0, -2)
    ChooseFile = textFile.ReadLine
    textFile.Close
    Set textFile = Nothing
    fso.DeleteFile (powershellFile)
    fso.DeleteFile (powershellOutputFile)

End Function

如果使用網路直接下載,遇到「安全通道支援發生錯誤」的錯誤訊息,可以參考這篇進行修正:
https://support.microsoft.com/zh-tw/help/3140245/update-to-enable-tls-1-1-and-tls-1-2-as-a-default-secure-protocols-in

如果還是沒辦法直接下載,則先手動下載XML檔案,再使用選擇檔案的方式轉入程式中使用,XML檔案下載位置:
https://data.gov.tw/datasets/export/xml

匯入之後的資料如以下畫面,可以再另外開發程式介面來更新與搜尋資料,就看自己的用途如何了。
https://ithelp.ithome.com.tw/upload/images/20181113/20007221DwRWjRtXXW.png

如果需要更詳細的教學,可以參考以下網址:

Working with XML files in VBA (VBA XML)
https://analystcave.com/vba-xml-working-xml-files/

A Beginner's Guide to the XML DOM
https://msdn.microsoft.com/en-us/library/aa468547.aspx

筆者另外建立了一個頁面進行建立資料表、下載/匯入檔案、開啟資料表、移除資料表,之後有興趣的可以參考裡面的程式碼:
https://ithelp.ithome.com.tw/upload/images/20181113/20007221A6rR44cruh.png


上一篇
Access VBA 之 iT管理實做Day28: 顯示Crystal Report(水晶報表)
下一篇
Access VBA 之 iT管理實做Day30: JSON資料的收集-以youtube-dl為例
系列文
Access VBA 之 iT管理實做30

尚未有邦友留言

立即登入留言