Complete Excel Address Data with Bing Maps API

http://dev.virtualearth.net/REST/v1/Locations/1600 %20Amphitheatre%20Pkwy%2C%20Mountain %20View %2C%20CA%2094043%2C%20USA?output=json&key=
AmVoAsOUH9QHTL4-Zc7qF7MjU8tm7zR9rDdXsA5QRsgudEwRJmz_a_NkGMmTUn3I

{"authenticationResultCode":"ValidCredentials", "brandLogoUri":"http:\/\/dev.virtualearth.net\/Branding\/logo_powered_by.png", "copyright":"Copyright © 2011 Microsoft and its suppliers. All rights reserved. This API cannot be accessed and the content and any results may not be used, reproduced or transmitted in any manner without express written permission from Microsoft Corporation.", "resourceSets":[{"estimatedTotal":1, "resources":[{"__type": "Location:http:\/\/schemas.microsoft.com\/search\/local\/ws\/rest\/v1",  "bbox":[37.418107282429325, -122.09062169320978, 37.425832717570678 ,-122.07765230679021], "name": "1600 Amphitheatre Pkwy,  Mountain View, CA 94043-1351","point":  {"type":"Point","coordinates": [37.42197,-122.084137]},"address":{"addressLine":"1600 Amphitheatre Pkwy", "adminDistrict": "CA", "adminDistrict2": "Santa Clara Co.","countryRegion": "United States","formattedAddress": "1600 Amphitheatre Pkwy,  Mountain View, CA 94043-1351", "locality":"Mountain View","postalCode":"94043-1351"}, "confidence":"High","entityType": "Address"}]}] , "statusCode":200, "statusDescription":"OK", "traceId":"a7f50cdaac934537b0e507f7c2f7bd62|LTSM001158 |02.00.126.3000|LTSMSNVM001475,  LTSMSNVM001457,  LTSMSNVM001461"}

This is very similar to the Google Maps version, and calls many of the same modules which I won’t bother repeating here.  We are doing the same thing – namely geoMapping and filling in named fields such as country etc as specified, and according to the rules in a parameter sheet.

Option Explicit
' NOTE: before using this please read the Bing terms and conditions
' http://www.microsoft.com/maps/product/licensing.aspx
' and read about the restful api here
' http://msdn.microsoft.com/en-us/library/ff701713.aspx
' this example is purely for educational purposes and is a step in creating a bing map
' YOU NEED TO GET YOUR OWN Bing KEY TO BUILD AN APPLICATION WITH THIS CODE
Const cBingApiUrl = "http://dev.virtualearth.net/REST/v1/Locations/"

Dim iDebug As Long
' this is all about parameter names

Public Sub bingMappingExample()
    Dim dSets As cDataSets, dr As cDataRow, sInput As String
    Dim jo As cJobject, cb As cBrowser, sReq As String, sWire As String
    iDebug = 1

    Set dSets = dSetsSetup
    If dSets Is Nothing Then Exit Sub
    ' now we have the data file and know that it contains an ID column and an address column
    ' now geocode the addresses - one by one (the final version will do it as a batch)
    Set cb = New cBrowser
    With dSets
        For Each dr In .DataSet(cMaster).Rows
            sInput = rxReplace("nonprintable", _
                dr.Cell(.DataSet(cParamFields).Cell _
                (cFieldAddress, cFieldValue).toString).toString, " ")
            sReq = cBingApiUrl & URLEncode(sInput) & _
             "?output=json&key=" & _
            dSets.DataSet(cBingParameters).Cell("Key", "Value").toString
            ' get mapping result
            sWire = cb.httpGET(sReq)
            Set jo = New cJobject
            With jo.deSerialize(sWire)
                If .isValid And Not .ChildExists("authenticationResultCode") Is Nothing Then
                ' now we have a cjobject of every field in the response
                    If .Child("authenticationResultCode").toString = "ValidCredentials" Then
                        ' all is good go and find necessary fields
                        If .Child("resourcesets.1.estimatedtotal").Value < 1 Then
                            MsgBox ("No results for " & ":url" & sReq)
                        Else
                            bingSuitableJob .Child("resourceSets.1.resources"), _
                                    dr, Range("debug!a2")
                        End If
                    Else
                        MsgBox ("Unable to geomap - status " & .Child("authenticationResultCode").toString & ":url" & sReq)
                    End If
                Else
                    MsgBox ("Badly formed jSon response received to " & sReq)
                End If
            End With
            
            Set jo = Nothing
        Next dr
    End With
    Set dSets = Nothing
    Set cb = Nothing
End Sub

Private Sub bingSuitableJob(job As cJobject, dr As cDataRow, _
                                   Optional rDebug As Range = Nothing)
                                   
    'given a row, find the most appropriate object to populate it with
    Dim dc As cCell, pc As cCell, jo As cJobject, sName As String

    For Each dc In dr.Columns
        ' is this an interesting column ?
        sName = dr.Parent.Headings(dc.Column).toString
        With dr.Parent.Parent.DataSet(cParamRules)
            Set pc = .Cell(sName, 1)
            If Not pc Is Nothing Then
                ' it is a cell that needs filling in
                Set jo = bingMappingFind(job, _
                    LCase(.Cell(sName, "bing component").toString), _
                    LCase(.Cell(sName, "bing special").toString), _
                    rDebug)
                With dc
                    If jo Is Nothing Then
                        .Value = Empty
                    Else
                        .Value = jo.Value
                    End If
                    .Commit
                End With
            End If
        End With
    Next dc
    
End Sub

Private Function bingMappingFind(job As cJobject, _
            sComponent As String, sSpecial As String, _
            Optional rDebug As Range = Nothing) As cJobject
                    
    ' given a column name, what's the best fit in the structure response from geocoding
    Dim sValue As String, jo As cJobject, jResult As cJobject, sKey As String
    Dim st As String
    
    ' these are the parameters we will work with
    sKey = LCase(job.fullKey)
    sValue = LCase(job.toString)

    ' if you need a list this will show all seen api response values
    If Not rDebug Is Nothing Then
        rDebug.Offset(iDebug, 0).Value = sKey
        rDebug.Offset(iDebug, 1).Value = job.Value
        iDebug = iDebug + 1
    End If

    If sSpecial = "fullkey" Then
        ' fullkey needs no further matching
        If sKey = sComponent Then
            Set bingMappingFind = job
            Exit Function
        End If
    Else
        MsgBox ("Only full key implemented for bing")
    End If

    ' recurse for children
    If job.hasChildren Then
        For Each jo In job.Children
            Set jResult = bingMappingFind(jo, sComponent, sSpecial, rDebug)
            If Not jResult Is Nothing Then
                Set bingMappingFind = jResult
                Exit Function
            End If
        Next jo
    End If

End Function

Summary