Option Explicit
Private Const YAHOO_APPID As String = "[yourappidhere]"
Public Type Address
Latitude As Double
Longitude As Double
Name As String
Line1 As String
Line2 As String
Line3 As String
Line4 As String
Zip As String
End Type
Public Function Geocode(sAddress As String) As Address
Dim responseXML As DOMDocument
On Error GoTo Geocode_Error
With New WinHttpRequest
'Send our request to Yahoo
.Open "GET", createYahooPlaceFinderURI(sAddress)
.Send
Set responseXML = New DOMDocument
'load the response from Yahoo into an XML object
responseXML.Load .ResponseBody
Geocode = parseYahooResultXML(responseXML)
End With
Geocode_Exit:
On Error Resume Next
Set responseXML = Nothing
Exit Function
Geocode_Error:
Select Case Err
Case Else
MsgBox "Unhandled Error in Module1.Geocode", Err.Number, Err.Description, Err.Source, Erl()
End Select
Resume Geocode_Exit
Resume
End Function
Private Function createYahooPlaceFinderURI(sAddress As String) As String
'Build the requestURI as per [URL unfurl="true"]http://developer.yahoo.com/geo/placefinder/guide/requests.html[/URL]
Const baseURI As String = "[URL unfurl="true"]http://where.yahooapis.com/geocode?"[/URL]
Dim sLocation As String, sAppID As String
sLocation = "location=" & URLEncode(sAddress)
sAppID = "appid=" & sAppID
createYahooPlaceFinderURI = baseURI & sLocation & sAppID
End Function
Private Function URLEncode(StringVal As String, Optional SpaceAsPlus As Boolean = False) As String
'From [URL unfurl="true"]http://stackoverflow.com/questions/218181/how-can-i-url-encode-a-string-in-excel-vba[/URL]
Dim StringLen As Long: StringLen = Len(StringVal)
If StringLen > 0 Then
ReDim result(StringLen) As String
Dim i As Long, CharCode As Integer
Dim Char As String, Space As String
If SpaceAsPlus Then Space = "+" Else Space = "%20"
For i = 1 To StringLen
Char = Mid$(StringVal, i, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Char
Case 32
result(i) = Space
Case 0 To 15
result(i) = "%0" & Hex(CharCode)
Case Else
result(i) = "%" & Hex(CharCode)
End Select
Next i
URLEncode = Join(result, "")
End If
End Function
Private Function parseYahooResultXML(xml As DOMDocument) As Address
'Very basic parsing from [URL unfurl="true"]http://developer.yahoo.com/geo/placefinder/guide/responses.html[/URL]
'There is no error checking, no checking of quality etc.
Dim a As Address
With xml
With .SelectSingleNode("//ResultSet/Result")
a.Name = .SelectSingleNode("name").Text
a.Line1 = .SelectSingleNode("line1").Text
a.Line2 = .SelectSingleNode("line2").Text
a.Line3 = .SelectSingleNode("line3").Text
a.Line4 = .SelectSingleNode("line4").Text
a.Zip = .SelectSingleNode("postal").Text
a.Longitude = CDbl(.SelectSingleNode("longitude").Text)
a.Latitude = CDbl(.SelectSingleNode("latitude").Text)
End With
End With
parseYahooResultXML = a
End Function