使用 VBA 将 Google 地方详细信息转至 Excel答案

【问题标题】：Google Places Details to Excel with VBA使用 VBA 将 Google 地方详细信息转至 Excel
【发布时间】：2016-10-02 13:58:42
【问题描述】：

我正在尝试通过向 Google 发出文本搜索请求，将 Google 地点的完整详细列表添加到 Excel 工作表中。

所以我想通过

执行 API 查询 (?)

将搜索字符串写入 Excel 单元格
让 VBA 查询 Google“Place Search”并返回与搜索字符串匹配的 Placeid 临时列表
让 VBA 使用 Google“Place Details”查询上一步 Placeid 的所有详细信息并将其写入工作表

所以我理解的代码应该“链接”这两个 API。我已经有一个用于 Google 的 API 密钥。

【问题讨论】：

贴一些代码，甚至是伪代码。
堆栈溢出不是代码编写服务。

标签： vba excel api google-places-api

【解决方案1】：

好的，所以一些初始工作见 (BigTest() 和 EvenBiggerTest()) 看到之前编辑的剩余部分，但在重新阅读你的 cmets 之后，我可以看到你想要 TextSearch。请参阅请运行 TestTestSearch()

我已经让它知道多页，因为谷歌一次返回 20 行加上下一页标记（如果有更多的话）；所以提供下一页令牌以获取下一页。这不能可靠地工作，我不知道为什么，因为伦敦的餐厅永远不会超过 60 家。

请随意单步执行代码，我已经制作了大量的中间变量，您可以在 Locals Window 中观察这些变量以查看 JSON 结构。

有一些很好的 VBA.CallbyName 逻辑，很少有人知道关于询问 JSON 结构（我在韩国网站上找到的）。迫不及待地想在 Stackoverflow 上发布它。

您需要添加以下项目引用，它们会导入库

'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

【讨论】：

我得到了这个工作，它很棒！我仍然想念的是通过文本搜索生成第一个列表，例如maps.googleapis.com/maps/api/place/textsearch/… [+API 密钥]，然后从每个列表中检索所有文本字段，例如 maps.googleapis.com/maps/api/place/details/… [+API 密钥]。我尝试修改您的代码以使用文本搜索生成列表，但没有管理:(此外，我在尝试检索例如使用 JSON 的打开时间时遇到了问题，因为字段名称是相同的。有什么想法吗？
再来一次，请运行TestTestSearch()
这太棒了 - TestTextSearch() 完全按照我的意愿“链接”了两个 API - 非常感谢！我将继续使用代码来检索更多详细信息，例如每日开放时间（例如星期一 10-17 等），我相信我可以在您出色的代码上进行构建。谢谢@S-Meaden！

【解决方案2】：

请注意，这可能违反了 ToS。

根据 ToS 第 10.5 (d) 段

没有缓存或存储。您不会预取、缓存、索引或存储任何要在服务之外使用的内容，但由于网络延迟（以及不是为了阻止 Google 准确跟踪使用情况），并且仅在此类存储：是临时的（在任何情况下都不会超过 30 个日历日）；是安全的；不操纵或聚合内容或服务的任何部分；和不会以任何方式修改归属。

https://developers.google.com/maps/terms#10-license-restrictions

【讨论】：