Reverse Geocoding: Get Location Address from GPS coordinates(Latitude & Longitude)

[actjfc]

Excel friends,

I found the code below at:
Reverse Geocoding: Get Location Address from GPS coordinates(Latitude & Longitude)

I could not make it work for this website:
Latitude & Longitude to Address Tool | Melissa Lookups

Can somebody adapt it or provide a similar code to return only the ZIP CODE?
Please, let me know what VBA references do I need to check, if any.

Thanks!

Function GEOAddress(dblLatitude As Double, dblLongitude) As String
        
    Dim strJSON         As String
    Dim strAddress      As String
    Dim lngTemp         As Long
    Dim objXml          As Object
    Dim strUrl          As String
       
    strUrl = "http://maps.googleapis.com/maps/api/geocode/json?latlng=" & dblLatitude & "," & dblLongitude & "&sensor=false"
    Set objXml = CreateObject("Microsoft.XMLHTTP")
    With objXml
        .Open "GET", strUrl, False
        .send
        strJSON = .responseText
    End With
    Set objXml = Nothing
       
    lngTemp = InStr(1, strJSON, "formatted_address")
    strAddress = Mid(strJSON, lngTemp + 22, InStr(lngTemp, strJSON, """,") - (lngTemp + 22))
    GEOAddress = strAddress
   
End Function

 

[Anthony47]

These Google APIs are no longer free, you need to get an "ApiCode" from Google.
See Get Started | Geocoding API | Google Developers

To get the ApiKey you need to authorize Google to charge for the cost of the service, but there is a recurring $200 monthly credit (that is a base free service)

Bye

 

[actjfc]

Thanks, Anthony47, yes, you are right for Google Map Services. However, the link I provided above is for Melissa.com. I need to reverse about 100 geo locations a day for a few weeks. So, if I can pull the Zip Code one by one from Melissa, then I think it should be possible to use a similar code to pull 100 automatically with a VBA function , but I do not know how to adapt it. Maybe Melissa site uses Google Services but they do not ask for API Keys. Can you help to adapt it? Am I wrong in my appreciation of the requisites to get this done?

Thanks?

 

[Anthony47]

I had a look at melissa.com, but the problem is that they require a registration and I have not the knowledge to login to the site using a WinHTTPRequest. I understand that you will work with batches of addresses, so it should be manageable with using the InternetExplorer automation library (mshtml.tlb) with manual login at the beginning of the work.
However to evaluate that option I need a sample worksheet containing sample starting information and the description of wich "Lookup" service should be used at melissa.com to obtain which type of information.

In the meantime I have been working with a site that don't require registration: mapdevelopers.com; the problem with this site is that it is very slow in responding, so a WinHTTPRequest returns no results. Therefore I switched to using the InternetExplorer object, that don't make the response faster but allows the code to get synchronized with the late datas.

The result of this effort is the following code:

Dim IE As Object
Sub MapInfoTest()
'Fixed Start block >>>:
Dim RARR As Variant
Set IE = CreateObject("InternetExplorer.Application")
'<<<
For I = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    Call GetMapInfo(Cells(I, 1).Value, Cells(I, 2).Value, RARR)
    'now RARR contains an array of 4 rows * 2 columns
    '
    'This is an example of how using RARR
    Cells(I, "K").Resize(1, 2).Value = Application.WorksheetFunction.Index(RARR, 2, 0)
Next I
'Fixed End block >>>:
On Error Resume Next
    IE.Quit
    Set IE = Nothing
On Error GoTo 0
'<<<
End Sub
Function SetMapInfo(ByVal LLat As String, LLOng As String) As Variant
'Fixed Start block >>>:
Dim RARR As Variant
Set IE = CreateObject("InternetExplorer.Application")
'<<<
Call GetMapInfo(LLat, LLOng, RARR)
SetMapInfo = RARR
'Fixed End block >>>:
On Error Resume Next
    IE.Quit
    Set IE = Nothing
On Error GoTo 0
'<<<
End Function

Sub GetMapInfo(ByVal LLat As String, LLOng As String, ByRef myINFO As Variant)
Dim aColl As Object, bColl As Object, myStart As Single
Dim oArr(0 To 7, 0 To 1)
Dim myUrl As String, I As Long
'
myUrl = "https://www.mapdevelopers.com/geocode_tool.php?lat=" & LLat & "&lng=" & LLOng
'
'navigate in background to the url
With IE
    .navigate myUrl
'    .Visible = True
    Do While .Busy: DoEvents: Loop    'Attesa not busy
    Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
End With
'
myStart = Timer
On Error Resume Next
'Wait for the Data to be really ready...
Do
    Set aColl = IE.document.getElementsByClassName("row expander")
    Set bColl = aColl(0).getElementsByTagName("div")
    Debug.Print Format(Timer - myStart, "0.00"), bColl(1).innerText
    If Len(bColl(1).innerText) > 0 Then Exit Do
    If Timer > (myStart + 5) Or Timer < myStart Then Exit Do
Loop
'...then write the results...
For I = 0 To 3
    Set bColl = aColl(I).getElementsByTagName("div")
    oArr(I * 2, 0) = bColl(0).innerText
    oArr(I * 2, 1) = bColl(1).innerText
    oArr(I * 2 + 1, 0) = bColl(2).innerText
    oArr(I * 2 + 1, 1) = bColl(3).innerText
Next I
'...and return them
myINFO = oArr
On Error GoTo 0
End Sub

It is necessary that the code be inserted in a new, empty "standard vba module" of your vba project

It contains:
-a callable subroutine, Sub GetMapInfo, that interact with mapdevelopers.com
-two samples of callers:
a) the Function SetMapInfo, that can be used as an excel function: you pass to SetMapInfo the Lat and Long and it will return a list of 8 parametres:
Address /County /City /Country /State /Latitude /Zipcode /Longitude
Your formula determine which information will be returned

b) the macro Sub MapInfoTest, that works with a list of geo-coordinates; for each of the available pairs of Lat /Long it collect an array of the same 8 parametres, then the macro, as a demonstation on how using it, write near the coordinates the County

This image shows how they could be used:


Given the coordinates in columns A:B, the grayed areas show some example of using the Function SetMapInfo
The formula in D2, =SetMapInfo(A2,B2), has to be entered as an array formula (if you use Office 365 with the Dynamic array feature you don’t need to use Control-Shift-Enter).
Same in H2

In D12 and H12 you see how the formula uses INDEX to return a specific pair of information:
This returns ZipCode:

=INDEX(SetMapInfo(A2,B2),7,0)

This returns the Address:

=INDEX(SetMapInfo(A3,B3),1,0)

In Column K:L is is demonstrated how Sub MapInfoTest was used to list the counties of the coordinates written in columns A:B

The problem with the site that I used, let me repeat it, is that it is very slow in responding, so that Function SetMapInfo or Sub MapInfoTest will take seconds before returning the result.
Since Excel recalculate very often the formulas, even though their parametres didn't change, I think that using Function SetMapInfo has to be evaluated carefully; I developed it mainly as a demonstration of what could be done using vba and the many libraries that are available.

Sub MapInfoTest probably could be better exploited, as you decide when starting it, i.e. when you are ready for a cup of coffee.
Btw, no any explict reference is needed in your vba, we use "late binding" to create the necessary links.

See how you could play with these two options; if you prepare and share the sample worksheet as I said earlier I should be able to try with melissa.com

Bye

 

[actjfc]

Thanks, Anthony47, I do not understand why you say that Melissa requires registration. If I go to

https://www.melissa.com/v2/lookups/latlngzip4/?lat=40&lng=-94

I get at once the full address, and I need only the zip code from Lat=40 and Lng=-94. If I change the Lat and Lng to other numbers it works and does not ask me to register. I also have been testing Power Query but setting the Lat and Lng parameters is beyond my skills at this moment. I have watched some youtube "how to"s but I do not get Power Query from WEB to work for me as a defined function.

I tried the INDEX(SetMapInfo(A2,B2),7,0) from your code, but I get #VALUE! with and without Ctrl Shift-Enter. I may be doing something wrong because you have tested it. Since Melissa is quick and easy to get it work, I wonder if modifying your code above with something like

https://www.melissa.com /v2/lookups/latlngzip4/?lat=" & LLat & "&lng=" & LLOng

plus other changes will make the trick.

Thanks for your help!

 

[Anthony47]

This is what I get after a certain number of enquiries:


If you provide a sample worksheet with your starting information and the detail of what lookup you need, then I think we can prepare a macro that when run gives you the option for login and the checks each of the starting information to get the lookup information you need.

As far as the SetMapInfo function, try writing Lat and Long as "strings", not numbers; i.e.try typing in the cell

'40.742185

(note the "apostrophe" before the number)

Bye

 

[Anthony47]

I got a reasonable version of the User-Defined Function GetMelissaInfo, that rely on the services provided by melissa.com for geocoding based on site Latitude & Longitude.

It was neither so simple nor straightforward, because (as I demonstrated in my previous message) a login to melissa.com is necessary to exploit their services, and without login you cannot make more that a few queries. Also that page doesn't handle correctly the browser "ReadyState", in that it never reaches the condition of READYSTATE_COMPLETE (constant 4), but stops in READYSTATE_INTERACTIVE (constant 3).
Also there is the prerequisite that an InternetExplorer session must be open and the user has to use that session to login to melissa.com before the Function can return valid data.

That said, the code to be used is the following:

Function GetMelissaInfo(ByVal LLAt As String, ByVal LLONG As String, _
Optional ByVal dDbg As Boolean = False, Optional ByVal TTO As Single) As Variant
'Given Latitude and Longitude, returns the Address Elements of a site
'See https://www.melissa.com/v2/lookups/latlngzip4/ for behaviour and limits
'
'Syntax:   GetMelissaInfo(LAT, LONG, DebugInfo, TimeOut)
'   LAT is the Latitude in Degree, as a string
'   LONG is the Longitude, as s string
'   DebugInfo is optional, can be True or False (default value); if True debug info are printed
'   TimeOut is optional, is the forced timeout for terminating the Function; default is 5 sec
'
'   The function will return an Array 4 rows * 2 columns with the address elements provided by melissa.com
'
'Example:   =GetMelissaInfo(A2, B2)
'           Will return the address elements using Lat and Long in A2 and B2
'
'           =GetMelissaInfo(A2, B2,,2)
'           Same as above, but the function will be terminated anyway after 2 seconds
'
'
Dim IE As Object
Set IE = GetIE
Dim oArr(1 To 6, 1 To 2), TBL As Object, MErr As String
Dim myUrl As String, TBR As Object, I As Long, J As Long, myStart As Single
Dim rFlag As Boolean, tbLen As Long, tbOld As Long
'
If TTO < 0.1 Then TTO = 5
'
Debug.Print vbCrLf & ">>>>>", Parent.Caller.Address
If dDbg Then Debug.Print "Lat/Long:", LLAt, LLONG
myUrl = "https://www.melissa.com/v2/lookups/latlngzip4/?lat=" & LLAt & "&lng=" & LLONG
If IE Is Nothing Then MErr = "No IE"    'There isn't an open IE session
GetOut:
If Len(MErr) > 2 Then
    For I = 1 To UBound(oArr)
        For J = 1 To UBound(oArr, 2)
            oArr(I, J) = MErr
        Next J
    Next I
    If dDbg Then Debug.Print "Abort", Format(Timer - myStart, "0.00"), MErr
    GetMelissaInfo = oArr
    Exit Function
End If
myStart = Timer
With IE
    If dDbg Then Debug.Print "A-Start", Format(Timer - myStart, "0.00")
    .navigate myUrl
    .Visible = True
    myWait 0.1
    If dDbg Then Debug.Print "B-Start", Format(Timer - myStart, "0.00")
    Do While .Busy: DoEvents: Loop      'Attesa not busy
    If dDbg Then Debug.Print "C-NotBusy", Format(Timer - myStart, "0.00")
    Do                                  'Attesa Document
        DoEvents
        myWait 0.2
        If dDbg Then Debug.Print "D-ReadySt?", Format(Timer - myStart, "0.00"), .readyState
        If .readyState > 2 Then Exit Do
        If Timer > (myStart + TTO) Or Timer < myStart Then Exit Do
    Loop
End With
    
WDoc:
DoEvents
If dDbg Then Debug.Print "Status", Format(Timer - myStart, "0.00"), IE.readyState
myWait (0.25)
'Check for specific errors:
If InStr(1, IE.document.getElementsByTagName("body")(0).innerText, "Please sign in or register", vbTextCompare) > 0 Then
    MErr = "Not Logged"
ElseIf InStr(1, IE.document.getElementsByTagName("body")(0).innerText, "Invalid value of L", vbTextCompare) > 0 Then
    MErr = "Invalid Lat /Long"
ElseIf InStr(1, IE.document.getElementsByTagName("body")(0).innerText, "Out of region", vbTextCompare) > 0 Then
    MErr = "Out of Reg"
End If
If Len(MErr) > 2 Then
If dDbg Then Debug.Print "Error?", Format(Timer - myStart, "0.00"), IE.readyState, rFlag, MErr
    If rFlag Then
        GoTo GetOut
    Else
        MErr = ""
        rFlag = True
    End If
Else
    rFlag = False
End If
If rFlag Then myWait (0.25): GoTo WDoc
'
'Look for stable results:
On Error Resume Next
Set TBL = IE.document.getElementsByTagName("tbody")
Set TBR = TBL(0).getElementsByTagName("tr")
tbLen = 0
For I = 0 To TBR.Length - 1
    oArr(I + 1, 1) = TBR(I).getElementsByTagName("td")(0).innerText
    oArr(I + 1, 2) = TBR(I).getElementsByTagName("td")(1).innerText: tbLen = tbLen + Len(oArr(I + 1, 2))
Next I
On Error GoTo 0
If dDbg Then Debug.Print "tbLen & tbOld", tbLen, tbOld
If tbLen < 10 Or tbLen <> tbOld Then
    rFlag = True
    tbOld = tbLen
Else
    rFlag = False
End If
If Timer > (myStart + TTO) Or Timer < myStart Then rFlag = False
If rFlag Then GoTo WDoc
'Complete and exit:
GetMelissaInfo = oArr
If dDbg Then Debug.Print "EndF", Format(Timer - myStart, "0.00")
Set IE = Nothing
End Function

Function GetIE() As Object
'See https://stackoverflow.com/questions/25897956/get-existing-ie-via-vba
Dim ShellApp As Object, ShellWindows As Object
Dim IEObject As Object, ObjWInd As Object
'
Set ShellApp = CreateObject("Shell.Application")
Set ShellWindows = ShellApp.Windows()
Dim item As Object
On Error GoTo 0
Dim sName As String
For Each ObjWInd In ShellWindows
 'On Error Resume Next
    If (Not ObjWInd Is Nothing) Then
        sName = ObjWInd.Name
        If sName = "Internet Explorer" Then
            Set IEObject = ObjWInd
            Exit For  'No need to continue....
        End If
    End If
Next
'If IEObject Is Nothing Then Set IEObject = CreateObject("InternetExplorer.Application")
Set ShellApp = Nothing
Set GetIE = IEObject
End Function


Sub myWait(myStab As Single)
Dim myStTiM As Single
'Common wait loop
    myStTiM = Timer
    Do          'wait myStab
        DoEvents
        If Timer > myStTiM + myStab Or Timer < myStTiM Then Exit Do
    Loop
End Sub

The code has to be inserted in a "standard module" of your vba project

The code includes:
-the Function GetMelissaInfo
-the Function GetIE, used to lookup the active InternetExplorer session, copied from stackoverflow.com
-a Sub myWait, a programmable delay utility

The syntax of GetMelissaInfo is the following

'Syntax:   GetMelissaInfo(LAT, LONG, DebugInfo, TimeOut)
'   LAT is the Latitude in Degree, as a string
'   LONG is the Longitude, as s string
'   DebugInfo is optional, can be True or False (default value); if True debug info are printed
'   TimeOut is optional, is the forced timeout for terminating the Function; default is 5 sec
'
'   The function will return an Array 4 rows * 2 columns with the address elements provided by melissa.com
'
'Example:   =GetMelissaInfo(A2, B2)
'           Will return the address elements using Lat and Long in A2 and B2
'
'           =GetMelissaInfo(A2, B2,,2)
'           Same as above, but the function will be terminated anyway after 2 seconds

For example:



The grayed area shows the full address elements array returned by GetMelissaInfo; the formula used is shown above the gray area in bold; the coordinates point to Magnolia Boulevard, Burbank Ca.
The orage area shows how INDEX helps in getting the City for the 4 pairs of coordinates listed in columns A and B

Remember:
a) before the Function can return valid data, one InternetExplorer session has to be open and the user has to login on melissa.com; without login melissa.com will return valid data only on the first 10-20 queries
b) latitude and longitude need to be presented in decimal degrees (eg: 45.8765) as a String data type
c) the function returns an Array 4 Rows * 2 Columns; if you need specific elements you can use it in combination with INDEX; for example:

=INDEX(GetMelissaInfo(A2,B2),2,0)

This will return the 2nd row of the array

d) the Function need to contact melissa.com, push its coordinates, wait for the response; the overall time will be in the range of 1-2 seconds for each query. Since excel recalculate all the formulas quite often it could hang for several seconds while recalculating the formulas that use GetMelissaInfo.
Probably a better approach would be using GetMelissaInfo in a Macro, rather than in formulas. This will not make the function faster, but will let you decide when running the macro and collect all the information in the same occasion, and the results are not recalculated time by time but only when you run the macro.

I hope that what presented can be of some use

Bye