vba 解析JSON/XML总结笔记，以GoogleMap/OpenstreetMap-Nominatim为例

业务中用到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 Function

2.解析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 Function

3.解析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