业务中用到vba解析json/xml,这里进行总结笔记。
1.发送请求function
Public Function sendReq(ByRef URL As String) As String On Error GoTo err6 Dim HttpReq As MSXML2.XMLHTTP60 Dim ResponseStr As String 'XMLHTTPオブジェクトをセット Set HttpReq = New MSXML2.XMLHTTP60 With HttpReq .Open "GET", URL, varAsync:=False '非同期モードで通信を開始 .send 'リクエストを送信 If .Status <> 200 Then Exit Function 'リクエストが成功しなかったら終了 End With ResponseStr = HttpReq.responseText sendReq = ResponseStr Set HttpReq = Nothing Exit Function err6: Set HttpReq = Nothing MsgBox message_box("ERROR_204") End End Function2.解析Json
Function GoogleMap(ByVal adress As String) As String 'GoogleMaps API json形式でジオコードを取得 '戻り値:緯度(glat),経度(glng),ステータスをカンマ区切り Dim URL As String Dim objJSON As Object Dim strGeocode As String 'Google Maps Geocoding API URL = "https://maps.googleapis.com/maps/api/geocode/json?address=" & UrlEncodeUtf8(adress) jsonText = sendReq(URL) Dim gStatus As String Dim glat As String Dim glng As String Dim glocation_type As String Dim gGeometry As Object Dim gLocation As Object Dim gItem As Variant Dim gCount As Long
Set js = CreateObject("ScriptControl") js.Language = "JavaScript" 'jsonにパースする関数を追加 js.AddCode "function jsonParse(s) { return eval('(' + s + ')'); }" '追加した関数を実行して、結果を変数に格納する Set objJSON = js.CodeObject.jsonParse(jsonText) 'ステータス コード(status)を取得する gStatus = CallByName(objJSON, "status", VbGet) gCount = 0 '結果が複数あった場合はループさせる For Each gItem In CallByName(objJSON, "results", VbGet) '地域に関する補足データ(location_type)を取得する glocation_type = gItem.geometry.location_type 'geometryをオブジェクトにセットする Set gGeometry = CallByName(gItem, "geometry", VbGet) 'locationをオブジェクトにセットする Set gLocation = CallByName(gGeometry, "location", VbGet) '緯度を取得する glat = CallByName(gLocation, "lat", VbGet) '経度を取得する glng = CallByName(gLocation, "lng", VbGet) gCount = gCount + 1 Next 'ステータスの状態をチェック Select Case gStatus 'ジオコード成功の場合 Case "OK" strGeocode = glat & "," & glng If glocation_type = "ROOFTOP" Then strGeocode = strGeocode & "OK" If glocation_type = "APPROXIMATE" Then strGeocode = strGeocode & "位置情報は近似値です" If glocation_type = "RANGE_INTERPOLATED" Then strGeocode = strGeocode & "ジオコーディング出来ません" If glocation_type = "GEOMETRIC_CENTER" Then strGeocode = strGeocode & "-" '以下ステータスがOKでは無く問題があった場合 '緯度、経度は空白で返す Case "ZERO_RESULTS" strGeocode = "," Case "OVER_QUERY_LIMIT" strGeocode = "," Case "REQUEST_DENIED" strGeocode = "," Case "INVALID_REQUEST" strGeocode = "," Case "UNKNOWN_ERROR" strGeocode = "," End Select '結果(results)が複数ある場合 '緯度、経度は空白で返す If gCount >= 2 Then strGeocode = "," End If '結果を返す GoogleMap = strGeocode Set objJSON = Nothing Set gGeometry = Nothing Set gLocation = Nothing End Function3.解析XML。开始的时候用json,后来遇到64位的office用户不能使用ActiveX部件的scriptControl对象,但解析json的时候要用到scriptControl对象,所以更换使用xml。
获取URL函数
Function getURL(ByVal adress As String) As String On Error GoTo err3 Dim service As String Dim service_num As Integer Dim service_val As String Dim url_num As Integer Dim URL_p1 As String Dim URL_p2 As String Dim URL_p3 As String Dim i As Integer Dim j As Integer Dim URL As String service_num = Sheet4.[a65536].End(xlUp).Row url_num = Cells(2, 255).End(xlToLeft).Column service = Sheet1.Cells(1, 2).Value For i = 2 To service_num service_val = Sheet4.Cells(i, 1) If service = service_val Then URL_p1 = Sheet4.Cells(i, 8) For j = 9 To url_num URL_p3 = "&" & Sheet4.Cells(i, j) Next End If Next URL_p2 = UrlEncodeUtf8(adress) If URL_p1 + URL_p2 = "" Then MsgBox message_box("ERROR_201") End End If URL = URL_p1 + URL_p2 + URL_p3 ' URL = URL_p1 + URL_p3 getURL = URL Exit Function
GoogleMap & OpenStreetMap-Nominatim为例
Function WebService(ByVal adress As String) As String ' API xml形式でジオコードを取得 '戻り値:緯度(lat),経度(lon),ステータスをカンマ区切り On Error GoTo err4 Dim DomDoc As MSXML2.DOMDocument60 Dim ResponseStr As String Dim service As String Dim URL As String Dim strGeocode As String Dim lat As IXMLDOMNode Dim lon As IXMLDOMNode Dim placeId As IXMLDOMNode Dim results As Object Dim xmlStatus As IXMLDOMNode Dim nCount As Integer URL = getURL(adress) ResponseStr = sendReq(URL) Set DomDoc = New MSXML2.DOMDocument60 service = Sheet1.Cells(1, 2).Value 'XMLから情報を抽出する With DomDoc .LoadXML (ResponseStr) Select Case service Case "JA:Nominatim" 'searchresults要素を取得 Set results = .SelectSingleNode("//searchresults") nCount = 0 For Each results In results.ChildNodes If results.nodeName = "place" Then nCount = nCount + 1 End If Next If nCount = 1 Then 'Debug.Print placeId.Text 'lat要素(緯度)を取得 Set lat = .SelectSingleNode("//searchresults/place/@lat") 'lng要素(経度)を取得 Set lon = .SelectSingleNode("//searchresults/place/@lon") strGeocode = lat.Text & "," & lon.Text & ",INFO_201" ElseIf nCount = 0 Then strGeocode = "0,0,INFO_202" ElseIf nCount > 1 Then strGeocode = "0,0,INFO_207" End If Case "Google" Set results = .SelectSingleNode("//GeocodeResponse") nCount = 0 For Each results In results.ChildNodes If results.nodeName = "result" Then nCount = nCount + 1 End If Next 'status要素を取得 Set xmlStatus = .SelectSingleNode("//GeocodeResponse/status") Select Case xmlStatus.Text Case "OK" 'If xmlStatus.Text = "OK" Then 'lat要素(緯度)を取得 Set lat = .SelectSingleNode("//GeocodeResponse/result/geometry/location/lat") 'lng要素(経度)を取得 Set lon = .SelectSingleNode("//GeocodeResponse/result/geometry/location/lng") strGeocode = lat.Text & "," & lon.Text & ",INFO_201" Case "ZERO_RESULTS" strGeocode = "0,0,INFO_202" Case "OVER_QUERY_LIMIT" strGeocode = "0,0,INFO_203" Case "REQUEST_DENIED" strGeocode = "0,0,INFO_204" Case "INVALID_REQUEST" strGeocode = "0,0,INFO_205" Case "UNKNOWN_ERROR" strGeocode = "0,0,INFO_206" End Select '複数の結果が返ってきた場合 If nCount >= 2 Then strGeocode = "0,0,INFO_207" End If End Select End With '結果を返す WebService = strGeocode Set results = Nothing Set DomDoc = Nothing Exit Function err4: Set DomDoc = Nothing Set results = Nothing MsgBox message_box("ERROR_205") + Err.Description End End Function