VBA XML 取得即時公司登記資料(二)CODE步驟篇
原本是打算用JSON
http://stackoverflow.com/questions/5773683/excel-vba-parsed-json-object-loop
看到這篇就改用XML
http://stackoverflow.com/questions/9725882/getting-scriptcontrol-to-work-with-excel-2010-x64
步驟一.引用Microsorft XML v5.0
步驟二.將範例檔案另存
依照開放平台提供的範例 查詢
http://data.gcis.nat.gov.tw/od/data/api/6BBA2268-1367-4B42-9CCA-BC17499EBE8C?$format=xml&$filter=Company_Name like 台灣積體電路製造股份有限公司 and Company_Status eq 01
1: <?xml version="1.0" encoding="UTF-8" ?>
2:
3: - <data>
4:
5: - <row>
6:
7: <Business_Accounting_NO>22099131</Business_Accounting_NO>
8:
9: <Company_Status_Desc>核准設立</Company_Status_Desc>
10:
11: <Company_Name>台灣積體電路製造股份有限公司</Company_Name>
12:
13: <Capital_Stock_Amount>270500000000</Capital_Stock_Amount>
14:
15: <Paid_In_Capital_Amount>259293749560</Paid_In_Capital_Amount>
16:
17: <Responsible_Name>張OO</Responsible_Name>
18:
19: <Company_Location>新竹科學工業園區新竹市力行六路8號</Company_Location>
20:
21: <Register_Organization_Desc>科技部新竹科學工業園區管理局</Register_Organization_Desc>
22:
23: <Company_Setup_Date>0760221</Company_Setup_Date>
24:
25: <Change_Of_Approval_Data>1030903</Change_Of_Approval_Data>
26:
27: </row>
28:
29: </data>
30:
另存為本機資料
步驟三.測試是否可讀到本機XML檔
*參考http://pertonchang.blogspot.tw/2011/08/vbaxml.html
1: Public Sub Load_XML()
2:
3: Dim XMLDoc As Object
4:
5: Dim intState As Integer
6:
7: Dim strFileXML As String
8:
9: strFileXML = "D:\桌面\" & "book.xml"
10:
11: Set XMLDoc = New MSXML2.DOMDocument
12:
13: intState = XMLDoc.Load(strFileXML)
14:
15: ' intState 數值說明
16:
17: ' -1 成功
18:
19: ' 0 未初始化
20:
21: ' 1 載入中
22:
23: ' 2 已載入
24:
25: ' 3 互動
26:
27: ' 4 已完成
28:
29: If intState Then
30:
31: MsgBox "讀取 XML 成功"
32:
33: Else
34:
35: MsgBox "讀取 XML 失敗"
36:
37: End If
38:
39: Set XMLDoc = Nothing
40:
41: End Sub
42:
步驟四.測試取得網頁版資料
*參考http://club.excelhome.net/thread-783417-1-1.html
1: Private Sub CommandButton4_Click()
2:
3: bb = " http://data.gcis.nat.gov.tw/od/data/api/6BBA2268-1367-4B42-9CCA-BC17499EBE8C?$format=xml&$filter=Company_Name%20like%20%E5%8F%B0%E7%81%A3%E7%A9%8D%E9%AB%94%E9%9B%BB%E8%B7%AF%E8%A3%BD%E9%80%A0%E8%82%A1%E4%BB%BD%E6%9C%89%E9%99%90%E5%85%AC%E5%8F%B8%20and%20Company_Status%20eq%2001 "
4:
5: Dim XMLDoc As Object
6:
7: Dim intState As Integer
8:
9: Dim strFileXML As String
10:
11: strFileXML = bb
12:
13: Set XMLDoc = New MSXML2.DOMDocument
14:
15: intState = XMLDoc.Load(strFileXML)
16:
17: ' intState 數值說明
18:
19: ' -1 成功
20:
21: ' 0 未初始化
22:
23: ' 1 載入中
24:
25: ' 2 已載入
26:
27: ' 3 互動
28:
29: ' 4 已完成
30:
31: If intState Then
32:
33: MsgBox "讀取 XML 成功"
34:
35: Dim objDOM As Object
36:
37: Dim targetNode As Object
38:
39: 'UTF-8
40:
41: Set objDOM = CreateObject("MSXML2.DOMDocument")
42:
43: '普通格式
44:
45: 'Set objDOM = CreateObject("MSXML.DOMDocument")
46:
47: objDOM.async = False
48:
49: ret = objDOM.Load(bb)
50:
51: Dim objPageHeader As Object
52:
53: If ret Then
54:
55: Set targetNode = objDOM.DocumentElement.SelectNodes("//Company_Status_Desc")
56:
57: '取得節點值
58:
59: For Each Clone In targetNode
60:
61: Set ChartUnit = Clone.CloneNode(True)
62:
63: Set Node = ChartUnit.FirstChild
64:
65: Do While ChartUnit.HasChildNodes = True
66:
67: MsgBox Node.nodeName & " : " & Node.Text
68:
69: '子節點
70:
71: If Node.nodeName = ChartUnit.LastChild.nodeName Then Exit Do
72:
73: Set Node = Node.NextSibling
74:
75: Loop '//Do While node.haschildnodes = True
76:
77: Next Clone
78:
79: End If
80:
81: Else
82:
83: MsgBox "讀取 XML 失敗"
84:
85: End If
86:
87: Set XMLDoc = Nothing
88:
89: End Sub
90:
步驟五.自訂義參數傳送
1: bb="http://data.gcis.nat.gov.tw/od/data/api/6BBA2268-1367-4B42-9CCA-BC17499EBE8C?$format=xml&$filter=Company_Name like 吉and Company_Status eq 01" & ".xml"
*****這時會發現傳送的參數無法讀取
因為所傳遞的空格和文字都沒有經過編碼
參考http://blog.urdada.net/2005/09/08/24/
步驟六.在模組新增一個編碼UTF8的function
1: Public Function UrlEncode(ByRef szString As String) As String
2:
3: Dim szChar As String
4:
5: Dim szTemp As String
6:
7: Dim szCode As String
8:
9: Dim szHex As String
10:
11: Dim szBin As String
12:
13: Dim iCount1 As Integer
14:
15: Dim iCount2 As Integer
16:
17: Dim iStrLen1 As Integer
18:
19: Dim iStrLen2 As Integer
20:
21: Dim lResult As Long
22:
23: Dim lAscVal As Long
24:
25: szString = Trim$(szString)
26:
27: iStrLen1 = Len(szString)
28:
29: For iCount1 = 1 To iStrLen1
30:
31: szChar = Mid$(szString, iCount1, 1)
32:
33: lAscVal = AscW(szChar)
34:
35: If lAscVal >= &H0 And lAscVal <= &HFF Then
36:
37: If (lAscVal >= &H30 And lAscVal <= &H39) Or _
38:
39: (lAscVal >= &H41 And lAscVal <= &H5A) Or _
40:
41: (lAscVal >= &H61 And lAscVal <= &H7A) Then
42:
43: szCode = szCode & szChar
44:
45: Else
46:
47: szCode = szCode & "%" & Hex(AscW(szChar))
48:
49: End If
50:
51: Else
52:
53: szHex = Hex(AscW(szChar))
54:
55: iStrLen2 = Len(szHex)
56:
57: For iCount2 = 1 To iStrLen2
58:
59: szChar = Mid$(szHex, iCount2, 1)
60:
61: Select Case szChar
62:
63: Case Is = "0"
64:
65: szBin = szBin & "0000"
66:
67: Case Is = "1"
68:
69: szBin = szBin & "0001"
70:
71: Case Is = "2"
72:
73: szBin = szBin & "0010"
74:
75: Case Is = "3"
76:
77: szBin = szBin & "0011"
78:
79: Case Is = "4"
80:
81: szBin = szBin & "0100"
82:
83: Case Is = "5"
84:
85: szBin = szBin & "0101"
86:
87: Case Is = "6"
88:
89: szBin = szBin & "0110"
90:
91: Case Is = "7"
92:
93: szBin = szBin & "0111"
94:
95: Case Is = "8"
96:
97: szBin = szBin & "1000"
98:
99: Case Is = "9"
100:
101: szBin = szBin & "1001"
102:
103: Case Is = "A"
104:
105: szBin = szBin & "1010"
106:
107: Case Is = "B"
108:
109: szBin = szBin & "1011"
110:
111: Case Is = "C"
112:
113: szBin = szBin & "1100"
114:
115: Case Is = "D"
116:
117: szBin = szBin & "1101"
118:
119: Case Is = "E"
120:
121: szBin = szBin & "1110"
122:
123: Case Is = "F"
124:
125: szBin = szBin & "1111"
126:
127: Case Else
128:
129: End Select
130:
131: Next iCount2
132:
133: szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6)
134:
135: For iCount2 = 1 To 24
136:
137: If Mid$(szTemp, iCount2, 1) = "1" Then
138:
139: lResult = lResult + 1 * 2 ^ (24 - iCount2)
140:
141: Else: lResult = lResult + 0 * 2 ^ (24 - iCount2)
142:
143: End If
144:
145: Next iCount2
146:
147: szTemp = Hex(lResult)
148:
149: szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2)
150:
151: End If
152:
153: szBin = vbNullString
154:
155: lResult = 0
156:
157: Next iCount1
158:
159: UrlEncode = szCode
160:
161: End Function
162:
步驟七.重新組合編碼過的網址
1: bb = "http://data.gcis.nat.gov.tw/od/data/api/6BBA2268-1367-4B42-9CCA-BC17499EBE8C?$format=xml&$filter=Company_Name%20like%20%" & Right(UrlEncode("台灣積體電路製造股份有限公司"), Len(UrlEncode("台灣積體電路製造股份有限公司")) - 1) & "%20and%20Company_Status%20eq%2001"
步驟八.完成
