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
