Google 使用 VBA 将详细信息添加到 Excel
Google Places Details to Excel with VBA
我正在尝试通过对 Google.[=15 的文本搜索请求获取 Google 个地点的完整详细列表到 Excel sheet =]
所以我想通过
执行 API 查询 (?)
将搜索字符串写入 Excel 单元格
让 VBA 查询 Google “Place Search” 并返回与搜索字符串匹配的临时 Placeid 列表
让VBA用Google“Place Details”查询上一步Placeid的所有详细信息并写入sheet
所以根据我的理解，代码应该 "chain" 这两个 API。我已经有 Google.
的 API 密钥
好的，一些初始工作请参阅（BigTest() 和 EvenBiggerTest()），请参阅之前编辑的内容，但在重新阅读您的评论后，我可以看到您想要 TextSearch。请参阅 运行 TestTestSearch()
我已经做到了多页感知，因为 Google returns 一次 20 行加上下一页标记（如果还有的话）；所以一个人提供下一页令牌来获取下一页。这不能可靠地工作，我不知道为什么，因为伦敦的餐馆从不超过 60 家。
随意单步执行代码，我制作了大量的中间变量，您可以在 Locals Window 中观察以查看 JSON 结构。
有一些很好的 VBA.CallbyName 逻辑，很少有人知道关于询问 JSON 结构（我在韩国网站上找到的）。渴望在 Whosebug 上 post 它。
您需要添加以下项目引用，它们会导入库
'Tools->References->
'Microsoft Scripting Runtime
'Microsoft Script Control 1.0; {0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}; C:\Windows\SysWOW64\msscript.ocx
'Microsoft Xml, v6.0
Option Explicit
Option Private Module
Public Const sKEYNAME As String = "Server key 1"
'Public Const sKEY As String = "Your key goes here and uncomment"
Public Const sSEVENOAKS_PLACEID As String = "ChIJwd9bXUyt2EcRYv6GY0JRnCw" 'Place ID: ChIJwd9bXUyt2EcRYv6GY0JRnCw Sevenoaks , Sevenoaks, Kent, UK
Public Const sSEVENOAKS_LATITUDE_LONGITUDE As String = "51.2724,0.1909" '51.2724° N, 0.1909° E
Private Sub BigTest()
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Sevenoaks")
ReDim v(1 To dicPlacesWithPlaceIds.Count + 1, 1 To 2)
v(1, 1) = "Place": v(1, 2) = "Lat, Long"
Dim lLoop As Long
For lLoop = 1 To dicPlacesWithPlaceIds.Count
Dim sPlace As String
sPlace = dicPlacesWithPlaceIds.Keys()(lLoop - 1)
Dim sPlaceID As String
sPlaceID = dicPlacesWithPlaceIds.Items()(lLoop - 1)
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = PlaceDetails(sKey, sPlaceID)
v(lLoop + 1, 1) = sPlace
v(lLoop + 1, 2) = dicPlaceDetails.Items()(0)
Next
'Stop
ActiveSheet.Cells(1, 1).CurrentRegion.Clear
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicPlacesWithPlaceIds.Count + 1, 2)).Value2 = v
End Sub
Private Sub EvenBiggerTest()
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Hamburg")
If dicPlacesWithPlaceIds.Count > 0 Then
Dim sTopPrediction As String
sTopPrediction = dicPlacesWithPlaceIds.Keys()(0)
Dim sTopPredictionPlaceId As String
sTopPredictionPlaceId = dicPlacesWithPlaceIds.Items()(0)
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = PlaceDetails(sKey, sTopPredictionPlaceId)
Dim sTopPredictionLocation As String
sTopPredictionLocation = dicPlaceDetails.Item("Location")
Dim dicNearbySearchResults As Scripting.Dictionary
Set dicNearbySearchResults = NearbySearch(sKey, sTopPredictionLocation, 100, "post office")
ReDim v(1 To dicNearbySearchResults.Count + 1, 1 To 5)
v(1, 1) = "Name": v(1, 2) = "PlaceId": v(1, 3) = "Address": v(1, 4) = "Vicinity": v(1, 5) = "Type0"
'dicPlaceDetails.Add "Location", sLatitude & "," & sLongitude
'dicPlaceDetails.Add "Address", VBA.CallByName(objResult, "formatted_address", VbGet)
'dicPlaceDetails.Add "Name", VBA.CallByName(objResult, "name", VbGet)
'dicPlaceDetails.Add "Vicinity", VBA.CallByName(objResult, "vicinity", VbGet)
'dicPlaceDetails.Add "PlaceId", sPlaceID
Dim lLoop As Long
For lLoop = 1 To dicNearbySearchResults.Count
Dim sPlaceIdLoop As String
sPlaceIdLoop = dicNearbySearchResults.Items()(lLoop - 1)
Set dicPlaceDetails = PlaceDetails(sKey, sPlaceIdLoop)
v(lLoop + 1, 1) = dicNearbySearchResults.Keys()(lLoop - 1)
v(lLoop + 1, 2) = sPlaceIdLoop
v(lLoop + 1, 3) = dicPlaceDetails.Item("Address")
If dicPlaceDetails.Exists("Vicinity") Then
v(lLoop + 1, 4) = dicPlaceDetails.Item("Vicinity")
End If
If dicPlaceDetails.Exists("Type0") Then
v(lLoop + 1, 5) = dicPlaceDetails.Item("Type0")
End If
'dicNearbySearchResults.Items()(lLoop - 1)
Next
'Stop
ActiveSheet.Cells(1, 1).CurrentRegion.Clear
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicNearbySearchResults.Count + 1, 5)).Value2 = v
End If
End Sub
Private Sub TestAutoComplete()
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Sevenoaks")
Debug.Assert dicPlacesWithPlaceIds.Keys()(0) = "Sevenoaks, United Kingdom"
Debug.Assert dicPlacesWithPlaceIds.Items()(0) = sSEVENOAKS_PLACEID
End Sub
Private Sub TestNearbySearch()
Dim dicNearbySearchResults As Scripting.Dictionary
Set dicNearbySearchResults = NearbySearch(sKey, sSEVENOAKS_LATITUDE_LONGITUDE, 500, "restaurant")
Debug.Assert dicNearbySearchResults.Exists("Subway")
Debug.Assert dicNearbySearchResults.Item("Subway") = "ChIJ_yoN0_tN30cRnjjjqftbnSw"
Stop
End Sub
Private Sub TestPlaceDetails()
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = PlaceDetails(sKey, sSEVENOAKS_PLACEID)
Debug.Assert dicPlaceDetails.Keys()(0) = "Location"
Debug.Assert dicPlaceDetails.Items()(0) = "51.27241,0.190898"
End Sub
Private Sub TestTextSearch()
Dim pdicFieldOrinals As Scripting.Dictionary
Dim dicTextSearchResults As Scripting.Dictionary
Set dicTextSearchResults = TextSearch(sKey, "london+restaurants", pdicFieldOrinals)
Dim dicDetails As Scripting.Dictionary
Set dicDetails = dicTextSearchResults.Item(dicTextSearchResults.Keys()(0))
Dim vGrid As Variant
vGrid = NestedDictionaryToGrid(dicTextSearchResults, pdicFieldOrinals)
ActiveSheet.Cells(1, 1).CurrentRegion.Clear
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicTextSearchResults.Count + 1, pdicFieldOrinals.Count)).Value2 = vGrid
'd'ebug.Print dicDetails.Item("lat,lng")
'Debug.Print dicDetails.Item("types")
'Stop
'Debug.Assert dicTextSearchResults.Exists("Subway")
'Debug.Assert dicTextSearchResults.Item("Subway") = "ChIJ_yoN0_tN30cRnjjjqftbnSw"
'Stop
End Sub
Public Function CreateScriptControl() As ScriptControl
Static oScriptEngine As ScriptControl
If oScriptEngine Is Nothing Then
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
oScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
End If
Set CreateScriptControl = oScriptEngine
End Function
Public Function TextSearch(ByVal sAPIKey As String, ByVal sSearchQuery As String, ByRef pdicFieldOrinals As Scripting.Dictionary) As Scripting.Dictionary
'
'Tools->References->
'Microsoft Scripting Runtime
Dim dicTextSearchResults As Scripting.Dictionary
Set dicTextSearchResults = New Scripting.Dictionary
Set pdicFieldOrinals = New Scripting.Dictionary
Dim psNextPageToken As String: psNextPageToken = ""
Dim oScriptEngine As ScriptControl
Set oScriptEngine = CreateScriptControl
Do
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
Dim sURL As String
sURL = "https://maps.googleapis.com/maps/api/place/textsearch/json?key=" & sAPIKey & "&query=" & sSearchQuery
If psNextPageToken <> "" Then sURL = sURL & "&pagetoken=" & psNextPageToken
xHTTPRequest.Open "GET", sURL
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
Debug.Print Left$(xHTTPRequest.responseText, 500)
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")")
ParseTextSearchResponse oScriptEngine, objJSON, dicTextSearchResults, pdicFieldOrinals, psNextPageToken
End If
Loop Until psNextPageToken = ""
Set TextSearch = dicTextSearchResults
End Function
Public Function ParseTextSearchResponse(ByVal oScriptEngine As ScriptControl, ByVal objJSON As Object, _
ByVal dicTextSearchResults As Scripting.Dictionary, ByVal dicFieldOrinals As Scripting.Dictionary, _
ByRef psPageToken As String)
If Not objJSON Is Nothing Then
Dim dicTopKeys As Scripting.Dictionary
Set dicTopKeys = GetKeys(oScriptEngine, objJSON)
If dicTopKeys.Exists("next_page_token") Then
psPageToken = VBA.CallByName(objJSON, "next_page_token", VbGet)
Else
psPageToken = ""
End If
If dicTopKeys.Exists("status") Then
Dim sStatus As String
sStatus = VBA.CallByName(objJSON, "status", VbGet)
If sStatus = "OK" Then
Dim objResults As Object
Set objResults = VBA.CallByName(objJSON, "results", VbGet)
Dim lLength As Long
lLength = VBA.CallByName(objResults, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objResultLoop As Object
Set objResultLoop = VBA.CallByName(objResults, CStr(lLoop), VbGet)
Dim sName As String
sName = VBA.CallByName(objResultLoop, "name", VbGet)
Dim dicKeys As Scripting.Dictionary
Set dicKeys = GetKeys(oScriptEngine, objResultLoop)
Dim dicFlattenedDetails As Scripting.Dictionary
Set dicFlattenedDetails = New Scripting.Dictionary
Dim vKeyLoop As Variant
For Each vKeyLoop In dicKeys.Keys
If Not dicFieldOrinals.Exists(vKeyLoop) Then dicFieldOrinals.Add vKeyLoop, dicFieldOrinals.Count
Dim vValue As Variant: vValue = Empty
Select Case vKeyLoop
Case "formatted_address", "icon", "id", "name", "permanently_closed", "place_id", "price_level", "rating", "reference":
vValue = VBA.CallByName(objResultLoop, vKeyLoop, VbGet)
dicFlattenedDetails.Add vKeyLoop, vValue
Case "geometry":
dicFlattenedDetails.Add "geometry", ExtractLatitudeAndLongitude(VBA.CallByName(objResultLoop, "geometry", VbGet))
Case "opening_hours":
dicFlattenedDetails.Add "opening_hours", ExtractOpeningHours(oScriptEngine, VBA.CallByName(objResultLoop, "opening_hours", VbGet))
Case "types":
dicFlattenedDetails.Add "types", ExtractTypes(VBA.CallByName(objResultLoop, "types", VbGet))
Case "photos":
'* NOT YET IMPLEMENTED
Case Else
Stop
End Select
Next vKeyLoop
Dim sPlaceID As String
sPlaceID = VBA.CallByName(objResultLoop, "place_id", VbGet)
Dim sVicinity As String
'sVicinity = VBA.CallByName(objResultLoop, "vicinity", VbGet)
dicTextSearchResults.Add sPlaceID, dicFlattenedDetails
Next
End If
End If
End If
End Function
Public Function ExtractOpeningHours(ByVal oScriptEngine As ScriptControl, ByVal objOpeningHours As Object) As String
Dim vOpenNow As Variant
vOpenNow = VBA.CallByName(objOpeningHours, "open_now", VbGet)
Dim bOpenNow As Boolean
bOpenNow = CBool(vOpenNow)
Dim objWeekdayText As Object
Set objWeekdayText = VBA.CallByName(objOpeningHours, "weekday_text", VbGet)
Dim lLength As Long
lLength = VBA.CallByName(objWeekdayText, "length", VbGet)
If lLength > 0 Then
Dim dicWeekdaysKeys As Scripting.Dictionary
Set dicWeekdaysKeys = GetKeys(oScriptEngine, objWeekdayText)
End If
ExtractOpeningHours = VBA.IIf(bOpenNow, "open", "closed")
End Function
Public Function ExtractTypes(ByVal objTypes As Object) As String
Dim lLength As Long
lLength = VBA.CallByName(objTypes, "length", VbGet)
Dim dicTypes As Scripting.Dictionary
Set dicTypes = New Scripting.Dictionary
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim sTypeLoop As String
sTypeLoop = VBA.CallByName(objTypes, CStr(lLoop), VbGet)
dicTypes.Add sTypeLoop, 0
Next lLoop
ExtractTypes = VBA.Join(dicTypes.Keys, "|")
End Function
Public Function GetKeys(ByVal oScriptEngine As ScriptControl, ByVal JsonObject As Object) As Scripting.Dictionary
Dim dicReturn As Scripting.Dictionary
Set dicReturn = New Scripting.Dictionary
Dim objKeysObject As Object
Set objKeysObject = oScriptEngine.Run("getKeys", JsonObject)
Dim lLength As Long
lLength = VBA.CallByName(objKeysObject, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim vKeyLoop As Variant
vKeyLoop = VBA.CallByName(objKeysObject, CStr(lLoop), VbGet)
Debug.Assert Not dicReturn.Exists(vKeyLoop)
dicReturn.Add vKeyLoop, 0
Next lLoop
Set GetKeys = dicReturn
End Function
Public Function NearbySearch(ByVal sAPIKey As String, ByVal sLocationLatitudeLongitude As String, ByVal lRadius As Long, _
ByVal sSearchType As String)
'
'Tools->References->
'Microsoft Scripting Runtime
Dim dicNearbySearchResults As Scripting.Dictionary
Set dicNearbySearchResults = New Scripting.Dictionary
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/nearbysearch/json?key=" & sAPIKey & "&location=" & sLocationLatitudeLongitude & "&radius=" & lRadius & "&type=" & sSearchType
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
'Debug.Print xHTTPRequest.responseText
Dim oScriptEngine As ScriptControl
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")")
If Not objJSON Is Nothing Then
If TypeName(CallByName(objJSON, "status", VbGet)) <> "Nothing" Then
Dim sStatus As String
sStatus = VBA.CallByName(objJSON, "status", VbGet)
If sStatus = "OK" Then
Dim objResults As Object
Set objResults = VBA.CallByName(objJSON, "results", VbGet)
Dim lLength As Long
lLength = VBA.CallByName(objResults, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objResultLoop As Object
Set objResultLoop = VBA.CallByName(objResults, CStr(lLoop), VbGet)
Dim sName As String
sName = VBA.CallByName(objResultLoop, "name", VbGet)
Dim sPlaceID As String
sPlaceID = VBA.CallByName(objResultLoop, "place_id", VbGet)
Dim sVicinity As String
'sVicinity = VBA.CallByName(objResultLoop, "vicinity", VbGet)
dicNearbySearchResults.Add sName, sPlaceID
Next
End If
End If
End If
End If
Set NearbySearch = dicNearbySearchResults
End Function
Public Function ExtractLatitudeAndLongitude(ByVal objGeometry As Object) As String
Dim objLocation As Object
Set objLocation = VBA.CallByName(objGeometry, "location", VbGet)
Dim sLatitude As String
sLatitude = VBA.CallByName(objLocation, "lat", VbGet)
Dim sLongitude As String
sLongitude = VBA.CallByName(objLocation, "lng", VbGet)
ExtractLatitudeAndLongitude = sLatitude & "," & sLongitude
End Function
Public Function PlaceDetails(ByVal sAPIKey As String, ByVal sPlaceID As String) As Scripting.Dictionary
'Tools->References->
'Microsoft Scripting Runtime
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = New Scripting.Dictionary
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/details/json?key=" & sAPIKey & "&placeid=" & sPlaceID
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
Dim oScriptEngine As ScriptControl
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")")
If Not objJSON Is Nothing Then
If TypeName(CallByName(objJSON, "result", VbGet)) <> "Nothing" Then
Dim objResult As Object
Set objResult = VBA.CallByName(objJSON, "result", VbGet)
If TypeName(CallByName(objResult, "geometry", VbGet)) <> "Nothing" Then
Dim objGeometry As Object
Set objGeometry = VBA.CallByName(objResult, "geometry", VbGet)
If TypeName(CallByName(objGeometry, "location", VbGet)) <> "Nothing" Then
Dim objLocation As Object
Set objLocation = VBA.CallByName(objGeometry, "location", VbGet)
Dim sLatitude As String
sLatitude = VBA.CallByName(objLocation, "lat", VbGet)
Dim sLongitude As String
sLongitude = VBA.CallByName(objLocation, "lng", VbGet)
dicPlaceDetails.Add "Location", sLatitude & "," & sLongitude
dicPlaceDetails.Add "Address", VBA.CallByName(objResult, "formatted_address", VbGet)
dicPlaceDetails.Add "Name", VBA.CallByName(objResult, "name", VbGet)
If JSONKeyExists(objResult, "vicinity", False) Then
dicPlaceDetails.Add "Vicinity", VBA.CallByName(objResult, "vicinity", VbGet)
End If
If JSONKeyExists(objResult, "types", True) Then
Dim objTypes As Object
Set objTypes = VBA.CallByName(objResult, "types", VbGet)
Dim lTypesLength As Long
lTypesLength = VBA.CallByName(objTypes, "length", VbGet)
Dim sType0 As String
sType0 = VBA.CallByName(objTypes, "0", VbGet)
dicPlaceDetails.Add "Type0", sType0
End If
dicPlaceDetails.Add "PlaceId", sPlaceID
End If
End If
End If
End If
End If
Set PlaceDetails = dicPlaceDetails
End Function
Private Function JSONKeyExists(ByRef objJSON As Object, ByVal sKey As String, ByVal bIsObject As Boolean)
On Error GoTo ErrHandler
If bIsObject Then
Dim obj As Object
Set obj = VBA.CallByName(objJSON, sKey, VbGet) 'If error this jumps to error handler
Else
Dim vValue As Variant
vValue = VBA.CallByName(objJSON, sKey, VbGet) 'If error this jumps to error handler
End If
JSONKeyExists = True
Exit Function
ErrHandler:
End Function
Public Function AutoComplete(ByVal sAPIKey As String, ByVal sPlaceText As String) As Scripting.Dictionary
'Tools->References->
'Microsoft Scripting Runtime
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = New Scripting.Dictionary
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/autocomplete/json?key=" & sAPIKey & "&input=" & sPlaceText & "&sensor=false", False
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
Dim oScriptEngine As ScriptControl
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")")
If Not objJSON Is Nothing Then
If TypeName(CallByName(objJSON, "predictions", VbGet)) <> "Nothing" Then
Dim objPredictions As Object
Set objPredictions = VBA.CallByName(objJSON, "predictions", VbGet)
Dim lLength As Long
'lLength = ScriptEngine.Run("getProperty", objPredictions, "length")
lLength = VBA.CallByName(objPredictions, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objPredictionLoop As Object
Set objPredictionLoop = VBA.CallByName(objPredictions, CStr(lLoop), VbGet)
Dim sPlaceDescription As String
sPlaceDescription = VBA.CallByName(objPredictionLoop, "description", VbGet)
Dim sPlaceID As String
sPlaceID = VBA.CallByName(objPredictionLoop, "place_id", VbGet)
dicPlacesWithPlaceIds.Add sPlaceDescription, sPlaceID
'Stop
Next
'Stop
End If
End If
'Stop
End If
Set AutoComplete = dicPlacesWithPlaceIds
'Debug.Print xHTTPRequest.responseText
End Function
Public Function NestedDictionaryToGrid(ByVal dicData As Scripting.Dictionary, ByVal dicFieldOrdinals As Scripting.Dictionary) As Variant
ReDim vRet(1 To dicData.Count + 1, 1 To dicFieldOrdinals.Count)
Dim vFieldKeyLoop As Variant
For Each vFieldKeyLoop In dicFieldOrdinals.Keys
vRet(1, dicFieldOrdinals.Item(vFieldKeyLoop) + 1) = vFieldKeyLoop
Next
Dim lRowLoop As Long: lRowLoop = 1
Dim vDataKeyLoop As Variant
For Each vDataKeyLoop In dicData.Keys
lRowLoop = lRowLoop + 1
Dim dicDetails As Scripting.Dictionary
Set dicDetails = dicData.Item(vDataKeyLoop)
For Each vFieldKeyLoop In dicFieldOrdinals.Keys
vRet(lRowLoop, dicFieldOrdinals.Item(vFieldKeyLoop) + 1) = dicDetails.Item(vFieldKeyLoop)
Next
Next vDataKeyLoop
NestedDictionaryToGrid = vRet
End Function
注意这一点，这可能违反了服务条款。
根据服务条款第 10.5 (d) 段
No caching or storage. You will not pre-fetch, cache, index, or store any Content to be used outside the Service, except that you may store limited amounts of Content solely for the purpose of improving the performance of your Maps API Implementation due to network latency (and not for the purpose of preventing Google from accurately tracking usage), and only if such storage:
is temporary (and in no event more than 30 calendar days);
is secure;
does not manipulate or aggregate any part of the Content or Service; and
does not modify attribution in any way.
https://developers.google.com/maps/terms#10-license-restrictions
我正在尝试通过对 Google.[=15 的文本搜索请求获取 Google 个地点的完整详细列表到 Excel sheet =]
所以我想通过
执行 API 查询 (?)将搜索字符串写入 Excel 单元格
让 VBA 查询 Google “Place Search” 并返回与搜索字符串匹配的临时 Placeid 列表
让VBA用Google“Place Details”查询上一步Placeid的所有详细信息并写入sheet
所以根据我的理解，代码应该 "chain" 这两个 API。我已经有 Google.
的 API 密钥好的，一些初始工作请参阅（BigTest() 和 EvenBiggerTest()），请参阅之前编辑的内容，但在重新阅读您的评论后，我可以看到您想要 TextSearch。请参阅 运行 TestTestSearch()
我已经做到了多页感知，因为 Google returns 一次 20 行加上下一页标记（如果还有的话）；所以一个人提供下一页令牌来获取下一页。这不能可靠地工作，我不知道为什么，因为伦敦的餐馆从不超过 60 家。
随意单步执行代码，我制作了大量的中间变量，您可以在 Locals Window 中观察以查看 JSON 结构。
有一些很好的 VBA.CallbyName 逻辑，很少有人知道关于询问 JSON 结构（我在韩国网站上找到的）。渴望在 Whosebug 上 post 它。
您需要添加以下项目引用，它们会导入库
'Tools->References->
'Microsoft Scripting Runtime
'Microsoft Script Control 1.0; {0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}; C:\Windows\SysWOW64\msscript.ocx
'Microsoft Xml, v6.0
Option Explicit
Option Private Module
Public Const sKEYNAME As String = "Server key 1"
'Public Const sKEY As String = "Your key goes here and uncomment"
Public Const sSEVENOAKS_PLACEID As String = "ChIJwd9bXUyt2EcRYv6GY0JRnCw" 'Place ID: ChIJwd9bXUyt2EcRYv6GY0JRnCw Sevenoaks , Sevenoaks, Kent, UK
Public Const sSEVENOAKS_LATITUDE_LONGITUDE As String = "51.2724,0.1909" '51.2724° N, 0.1909° E
Private Sub BigTest()
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Sevenoaks")
ReDim v(1 To dicPlacesWithPlaceIds.Count + 1, 1 To 2)
v(1, 1) = "Place": v(1, 2) = "Lat, Long"
Dim lLoop As Long
For lLoop = 1 To dicPlacesWithPlaceIds.Count
Dim sPlace As String
sPlace = dicPlacesWithPlaceIds.Keys()(lLoop - 1)
Dim sPlaceID As String
sPlaceID = dicPlacesWithPlaceIds.Items()(lLoop - 1)
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = PlaceDetails(sKey, sPlaceID)
v(lLoop + 1, 1) = sPlace
v(lLoop + 1, 2) = dicPlaceDetails.Items()(0)
Next
'Stop
ActiveSheet.Cells(1, 1).CurrentRegion.Clear
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicPlacesWithPlaceIds.Count + 1, 2)).Value2 = v
End Sub
Private Sub EvenBiggerTest()
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Hamburg")
If dicPlacesWithPlaceIds.Count > 0 Then
Dim sTopPrediction As String
sTopPrediction = dicPlacesWithPlaceIds.Keys()(0)
Dim sTopPredictionPlaceId As String
sTopPredictionPlaceId = dicPlacesWithPlaceIds.Items()(0)
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = PlaceDetails(sKey, sTopPredictionPlaceId)
Dim sTopPredictionLocation As String
sTopPredictionLocation = dicPlaceDetails.Item("Location")
Dim dicNearbySearchResults As Scripting.Dictionary
Set dicNearbySearchResults = NearbySearch(sKey, sTopPredictionLocation, 100, "post office")
ReDim v(1 To dicNearbySearchResults.Count + 1, 1 To 5)
v(1, 1) = "Name": v(1, 2) = "PlaceId": v(1, 3) = "Address": v(1, 4) = "Vicinity": v(1, 5) = "Type0"
'dicPlaceDetails.Add "Location", sLatitude & "," & sLongitude
'dicPlaceDetails.Add "Address", VBA.CallByName(objResult, "formatted_address", VbGet)
'dicPlaceDetails.Add "Name", VBA.CallByName(objResult, "name", VbGet)
'dicPlaceDetails.Add "Vicinity", VBA.CallByName(objResult, "vicinity", VbGet)
'dicPlaceDetails.Add "PlaceId", sPlaceID
Dim lLoop As Long
For lLoop = 1 To dicNearbySearchResults.Count
Dim sPlaceIdLoop As String
sPlaceIdLoop = dicNearbySearchResults.Items()(lLoop - 1)
Set dicPlaceDetails = PlaceDetails(sKey, sPlaceIdLoop)
v(lLoop + 1, 1) = dicNearbySearchResults.Keys()(lLoop - 1)
v(lLoop + 1, 2) = sPlaceIdLoop
v(lLoop + 1, 3) = dicPlaceDetails.Item("Address")
If dicPlaceDetails.Exists("Vicinity") Then
v(lLoop + 1, 4) = dicPlaceDetails.Item("Vicinity")
End If
If dicPlaceDetails.Exists("Type0") Then
v(lLoop + 1, 5) = dicPlaceDetails.Item("Type0")
End If
'dicNearbySearchResults.Items()(lLoop - 1)
Next
'Stop
ActiveSheet.Cells(1, 1).CurrentRegion.Clear
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicNearbySearchResults.Count + 1, 5)).Value2 = v
End If
End Sub
Private Sub TestAutoComplete()
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Sevenoaks")
Debug.Assert dicPlacesWithPlaceIds.Keys()(0) = "Sevenoaks, United Kingdom"
Debug.Assert dicPlacesWithPlaceIds.Items()(0) = sSEVENOAKS_PLACEID
End Sub
Private Sub TestNearbySearch()
Dim dicNearbySearchResults As Scripting.Dictionary
Set dicNearbySearchResults = NearbySearch(sKey, sSEVENOAKS_LATITUDE_LONGITUDE, 500, "restaurant")
Debug.Assert dicNearbySearchResults.Exists("Subway")
Debug.Assert dicNearbySearchResults.Item("Subway") = "ChIJ_yoN0_tN30cRnjjjqftbnSw"
Stop
End Sub
Private Sub TestPlaceDetails()
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = PlaceDetails(sKey, sSEVENOAKS_PLACEID)
Debug.Assert dicPlaceDetails.Keys()(0) = "Location"
Debug.Assert dicPlaceDetails.Items()(0) = "51.27241,0.190898"
End Sub
Private Sub TestTextSearch()
Dim pdicFieldOrinals As Scripting.Dictionary
Dim dicTextSearchResults As Scripting.Dictionary
Set dicTextSearchResults = TextSearch(sKey, "london+restaurants", pdicFieldOrinals)
Dim dicDetails As Scripting.Dictionary
Set dicDetails = dicTextSearchResults.Item(dicTextSearchResults.Keys()(0))
Dim vGrid As Variant
vGrid = NestedDictionaryToGrid(dicTextSearchResults, pdicFieldOrinals)
ActiveSheet.Cells(1, 1).CurrentRegion.Clear
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicTextSearchResults.Count + 1, pdicFieldOrinals.Count)).Value2 = vGrid
'd'ebug.Print dicDetails.Item("lat,lng")
'Debug.Print dicDetails.Item("types")
'Stop
'Debug.Assert dicTextSearchResults.Exists("Subway")
'Debug.Assert dicTextSearchResults.Item("Subway") = "ChIJ_yoN0_tN30cRnjjjqftbnSw"
'Stop
End Sub
Public Function CreateScriptControl() As ScriptControl
Static oScriptEngine As ScriptControl
If oScriptEngine Is Nothing Then
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
oScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
End If
Set CreateScriptControl = oScriptEngine
End Function
Public Function TextSearch(ByVal sAPIKey As String, ByVal sSearchQuery As String, ByRef pdicFieldOrinals As Scripting.Dictionary) As Scripting.Dictionary
'
'Tools->References->
'Microsoft Scripting Runtime
Dim dicTextSearchResults As Scripting.Dictionary
Set dicTextSearchResults = New Scripting.Dictionary
Set pdicFieldOrinals = New Scripting.Dictionary
Dim psNextPageToken As String: psNextPageToken = ""
Dim oScriptEngine As ScriptControl
Set oScriptEngine = CreateScriptControl
Do
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
Dim sURL As String
sURL = "https://maps.googleapis.com/maps/api/place/textsearch/json?key=" & sAPIKey & "&query=" & sSearchQuery
If psNextPageToken <> "" Then sURL = sURL & "&pagetoken=" & psNextPageToken
xHTTPRequest.Open "GET", sURL
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
Debug.Print Left$(xHTTPRequest.responseText, 500)
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")")
ParseTextSearchResponse oScriptEngine, objJSON, dicTextSearchResults, pdicFieldOrinals, psNextPageToken
End If
Loop Until psNextPageToken = ""
Set TextSearch = dicTextSearchResults
End Function
Public Function ParseTextSearchResponse(ByVal oScriptEngine As ScriptControl, ByVal objJSON As Object, _
ByVal dicTextSearchResults As Scripting.Dictionary, ByVal dicFieldOrinals As Scripting.Dictionary, _
ByRef psPageToken As String)
If Not objJSON Is Nothing Then
Dim dicTopKeys As Scripting.Dictionary
Set dicTopKeys = GetKeys(oScriptEngine, objJSON)
If dicTopKeys.Exists("next_page_token") Then
psPageToken = VBA.CallByName(objJSON, "next_page_token", VbGet)
Else
psPageToken = ""
End If
If dicTopKeys.Exists("status") Then
Dim sStatus As String
sStatus = VBA.CallByName(objJSON, "status", VbGet)
If sStatus = "OK" Then
Dim objResults As Object
Set objResults = VBA.CallByName(objJSON, "results", VbGet)
Dim lLength As Long
lLength = VBA.CallByName(objResults, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objResultLoop As Object
Set objResultLoop = VBA.CallByName(objResults, CStr(lLoop), VbGet)
Dim sName As String
sName = VBA.CallByName(objResultLoop, "name", VbGet)
Dim dicKeys As Scripting.Dictionary
Set dicKeys = GetKeys(oScriptEngine, objResultLoop)
Dim dicFlattenedDetails As Scripting.Dictionary
Set dicFlattenedDetails = New Scripting.Dictionary
Dim vKeyLoop As Variant
For Each vKeyLoop In dicKeys.Keys
If Not dicFieldOrinals.Exists(vKeyLoop) Then dicFieldOrinals.Add vKeyLoop, dicFieldOrinals.Count
Dim vValue As Variant: vValue = Empty
Select Case vKeyLoop
Case "formatted_address", "icon", "id", "name", "permanently_closed", "place_id", "price_level", "rating", "reference":
vValue = VBA.CallByName(objResultLoop, vKeyLoop, VbGet)
dicFlattenedDetails.Add vKeyLoop, vValue
Case "geometry":
dicFlattenedDetails.Add "geometry", ExtractLatitudeAndLongitude(VBA.CallByName(objResultLoop, "geometry", VbGet))
Case "opening_hours":
dicFlattenedDetails.Add "opening_hours", ExtractOpeningHours(oScriptEngine, VBA.CallByName(objResultLoop, "opening_hours", VbGet))
Case "types":
dicFlattenedDetails.Add "types", ExtractTypes(VBA.CallByName(objResultLoop, "types", VbGet))
Case "photos":
'* NOT YET IMPLEMENTED
Case Else
Stop
End Select
Next vKeyLoop
Dim sPlaceID As String
sPlaceID = VBA.CallByName(objResultLoop, "place_id", VbGet)
Dim sVicinity As String
'sVicinity = VBA.CallByName(objResultLoop, "vicinity", VbGet)
dicTextSearchResults.Add sPlaceID, dicFlattenedDetails
Next
End If
End If
End If
End Function
Public Function ExtractOpeningHours(ByVal oScriptEngine As ScriptControl, ByVal objOpeningHours As Object) As String
Dim vOpenNow As Variant
vOpenNow = VBA.CallByName(objOpeningHours, "open_now", VbGet)
Dim bOpenNow As Boolean
bOpenNow = CBool(vOpenNow)
Dim objWeekdayText As Object
Set objWeekdayText = VBA.CallByName(objOpeningHours, "weekday_text", VbGet)
Dim lLength As Long
lLength = VBA.CallByName(objWeekdayText, "length", VbGet)
If lLength > 0 Then
Dim dicWeekdaysKeys As Scripting.Dictionary
Set dicWeekdaysKeys = GetKeys(oScriptEngine, objWeekdayText)
End If
ExtractOpeningHours = VBA.IIf(bOpenNow, "open", "closed")
End Function
Public Function ExtractTypes(ByVal objTypes As Object) As String
Dim lLength As Long
lLength = VBA.CallByName(objTypes, "length", VbGet)
Dim dicTypes As Scripting.Dictionary
Set dicTypes = New Scripting.Dictionary
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim sTypeLoop As String
sTypeLoop = VBA.CallByName(objTypes, CStr(lLoop), VbGet)
dicTypes.Add sTypeLoop, 0
Next lLoop
ExtractTypes = VBA.Join(dicTypes.Keys, "|")
End Function
Public Function GetKeys(ByVal oScriptEngine As ScriptControl, ByVal JsonObject As Object) As Scripting.Dictionary
Dim dicReturn As Scripting.Dictionary
Set dicReturn = New Scripting.Dictionary
Dim objKeysObject As Object
Set objKeysObject = oScriptEngine.Run("getKeys", JsonObject)
Dim lLength As Long
lLength = VBA.CallByName(objKeysObject, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim vKeyLoop As Variant
vKeyLoop = VBA.CallByName(objKeysObject, CStr(lLoop), VbGet)
Debug.Assert Not dicReturn.Exists(vKeyLoop)
dicReturn.Add vKeyLoop, 0
Next lLoop
Set GetKeys = dicReturn
End Function
Public Function NearbySearch(ByVal sAPIKey As String, ByVal sLocationLatitudeLongitude As String, ByVal lRadius As Long, _
ByVal sSearchType As String)
'
'Tools->References->
'Microsoft Scripting Runtime
Dim dicNearbySearchResults As Scripting.Dictionary
Set dicNearbySearchResults = New Scripting.Dictionary
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/nearbysearch/json?key=" & sAPIKey & "&location=" & sLocationLatitudeLongitude & "&radius=" & lRadius & "&type=" & sSearchType
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
'Debug.Print xHTTPRequest.responseText
Dim oScriptEngine As ScriptControl
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")")
If Not objJSON Is Nothing Then
If TypeName(CallByName(objJSON, "status", VbGet)) <> "Nothing" Then
Dim sStatus As String
sStatus = VBA.CallByName(objJSON, "status", VbGet)
If sStatus = "OK" Then
Dim objResults As Object
Set objResults = VBA.CallByName(objJSON, "results", VbGet)
Dim lLength As Long
lLength = VBA.CallByName(objResults, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objResultLoop As Object
Set objResultLoop = VBA.CallByName(objResults, CStr(lLoop), VbGet)
Dim sName As String
sName = VBA.CallByName(objResultLoop, "name", VbGet)
Dim sPlaceID As String
sPlaceID = VBA.CallByName(objResultLoop, "place_id", VbGet)
Dim sVicinity As String
'sVicinity = VBA.CallByName(objResultLoop, "vicinity", VbGet)
dicNearbySearchResults.Add sName, sPlaceID
Next
End If
End If
End If
End If
Set NearbySearch = dicNearbySearchResults
End Function
Public Function ExtractLatitudeAndLongitude(ByVal objGeometry As Object) As String
Dim objLocation As Object
Set objLocation = VBA.CallByName(objGeometry, "location", VbGet)
Dim sLatitude As String
sLatitude = VBA.CallByName(objLocation, "lat", VbGet)
Dim sLongitude As String
sLongitude = VBA.CallByName(objLocation, "lng", VbGet)
ExtractLatitudeAndLongitude = sLatitude & "," & sLongitude
End Function
Public Function PlaceDetails(ByVal sAPIKey As String, ByVal sPlaceID As String) As Scripting.Dictionary
'Tools->References->
'Microsoft Scripting Runtime
Dim dicPlaceDetails As Scripting.Dictionary
Set dicPlaceDetails = New Scripting.Dictionary
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/details/json?key=" & sAPIKey & "&placeid=" & sPlaceID
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
Dim oScriptEngine As ScriptControl
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")")
If Not objJSON Is Nothing Then
If TypeName(CallByName(objJSON, "result", VbGet)) <> "Nothing" Then
Dim objResult As Object
Set objResult = VBA.CallByName(objJSON, "result", VbGet)
If TypeName(CallByName(objResult, "geometry", VbGet)) <> "Nothing" Then
Dim objGeometry As Object
Set objGeometry = VBA.CallByName(objResult, "geometry", VbGet)
If TypeName(CallByName(objGeometry, "location", VbGet)) <> "Nothing" Then
Dim objLocation As Object
Set objLocation = VBA.CallByName(objGeometry, "location", VbGet)
Dim sLatitude As String
sLatitude = VBA.CallByName(objLocation, "lat", VbGet)
Dim sLongitude As String
sLongitude = VBA.CallByName(objLocation, "lng", VbGet)
dicPlaceDetails.Add "Location", sLatitude & "," & sLongitude
dicPlaceDetails.Add "Address", VBA.CallByName(objResult, "formatted_address", VbGet)
dicPlaceDetails.Add "Name", VBA.CallByName(objResult, "name", VbGet)
If JSONKeyExists(objResult, "vicinity", False) Then
dicPlaceDetails.Add "Vicinity", VBA.CallByName(objResult, "vicinity", VbGet)
End If
If JSONKeyExists(objResult, "types", True) Then
Dim objTypes As Object
Set objTypes = VBA.CallByName(objResult, "types", VbGet)
Dim lTypesLength As Long
lTypesLength = VBA.CallByName(objTypes, "length", VbGet)
Dim sType0 As String
sType0 = VBA.CallByName(objTypes, "0", VbGet)
dicPlaceDetails.Add "Type0", sType0
End If
dicPlaceDetails.Add "PlaceId", sPlaceID
End If
End If
End If
End If
End If
Set PlaceDetails = dicPlaceDetails
End Function
Private Function JSONKeyExists(ByRef objJSON As Object, ByVal sKey As String, ByVal bIsObject As Boolean)
On Error GoTo ErrHandler
If bIsObject Then
Dim obj As Object
Set obj = VBA.CallByName(objJSON, sKey, VbGet) 'If error this jumps to error handler
Else
Dim vValue As Variant
vValue = VBA.CallByName(objJSON, sKey, VbGet) 'If error this jumps to error handler
End If
JSONKeyExists = True
Exit Function
ErrHandler:
End Function
Public Function AutoComplete(ByVal sAPIKey As String, ByVal sPlaceText As String) As Scripting.Dictionary
'Tools->References->
'Microsoft Scripting Runtime
Dim dicPlacesWithPlaceIds As Scripting.Dictionary
Set dicPlacesWithPlaceIds = New Scripting.Dictionary
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/autocomplete/json?key=" & sAPIKey & "&input=" & sPlaceText & "&sensor=false", False
xHTTPRequest.send
While xHTTPRequest.readyState <> 4
DoEvents
Wend
If Len(xHTTPRequest.responseText) > 0 Then
Dim oScriptEngine As ScriptControl
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")")
If Not objJSON Is Nothing Then
If TypeName(CallByName(objJSON, "predictions", VbGet)) <> "Nothing" Then
Dim objPredictions As Object
Set objPredictions = VBA.CallByName(objJSON, "predictions", VbGet)
Dim lLength As Long
'lLength = ScriptEngine.Run("getProperty", objPredictions, "length")
lLength = VBA.CallByName(objPredictions, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objPredictionLoop As Object
Set objPredictionLoop = VBA.CallByName(objPredictions, CStr(lLoop), VbGet)
Dim sPlaceDescription As String
sPlaceDescription = VBA.CallByName(objPredictionLoop, "description", VbGet)
Dim sPlaceID As String
sPlaceID = VBA.CallByName(objPredictionLoop, "place_id", VbGet)
dicPlacesWithPlaceIds.Add sPlaceDescription, sPlaceID
'Stop
Next
'Stop
End If
End If
'Stop
End If
Set AutoComplete = dicPlacesWithPlaceIds
'Debug.Print xHTTPRequest.responseText
End Function
Public Function NestedDictionaryToGrid(ByVal dicData As Scripting.Dictionary, ByVal dicFieldOrdinals As Scripting.Dictionary) As Variant
ReDim vRet(1 To dicData.Count + 1, 1 To dicFieldOrdinals.Count)
Dim vFieldKeyLoop As Variant
For Each vFieldKeyLoop In dicFieldOrdinals.Keys
vRet(1, dicFieldOrdinals.Item(vFieldKeyLoop) + 1) = vFieldKeyLoop
Next
Dim lRowLoop As Long: lRowLoop = 1
Dim vDataKeyLoop As Variant
For Each vDataKeyLoop In dicData.Keys
lRowLoop = lRowLoop + 1
Dim dicDetails As Scripting.Dictionary
Set dicDetails = dicData.Item(vDataKeyLoop)
For Each vFieldKeyLoop In dicFieldOrdinals.Keys
vRet(lRowLoop, dicFieldOrdinals.Item(vFieldKeyLoop) + 1) = dicDetails.Item(vFieldKeyLoop)
Next
Next vDataKeyLoop
NestedDictionaryToGrid = vRet
End Function
注意这一点，这可能违反了服务条款。
根据服务条款第 10.5 (d) 段
No caching or storage. You will not pre-fetch, cache, index, or store any Content to be used outside the Service, except that you may store limited amounts of Content solely for the purpose of improving the performance of your Maps API Implementation due to network latency (and not for the purpose of preventing Google from accurately tracking usage), and only if such storage: is temporary (and in no event more than 30 calendar days); is secure; does not manipulate or aggregate any part of the Content or Service; and does not modify attribution in any way.
https://developers.google.com/maps/terms#10-license-restrictions