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