Excel VBA‎ > ‎

Geography and IP address in VBA

I have came accross a problem in VBA where I needed to automate the default location entered in a billing system. For instance entering a customer city.

Some xml services can be used in combination with excel vba to accomplish such a task.

What I found is that the problem could be splitted in 2 tasks. The first tasks involved going from an IP address to one Longitude and Latitude. Then afterward one can find the nearest big city using those 2 information.

To get the Longitude and latitude in VBA, one can use those functions. To go from latitude to longitude to a city name, one would need to use some web services such as http://www.geonames.org/



Sub testcityname()
    Dim myarray As Variant
    Dim mycity As Variant
    Dim latitude As Double
    Dim longitude As Double
    myarray = GetLatLonbyIP
    latitude = myarray(2)
    longitude = myarray(3)
    GeoCoding latitude, longitude
End Sub

Function GetMSXML() As Object  '  MSXML2.XMLHTTP60
    On Error Resume Next
    Set GetMSXML = CreateObject("MSXML2.XMLHTTP.6.0")
End Function
Function GetDomDoc() As Object  ' MSXML2.DOMDocument
    On Error Resume Next
    Set GetDomDoc = CreateObject("MSXML2.DOMDocument.6.0")
End Function
Function GetNode(parentNode As Object, nodeNumber As Long) As Object
    On Error Resume Next
    ' if parentNode is a MSXML2.IXMLDOMNodeList
    Set GetNode = parentNode.Item(nodeNumber - 1)

    ' if parentNode is a MSXML2.IXMLDOMNode
    If GetNode Is Nothing Then
        Set GetNode = parentNode.childNodes(nodeNumber - 1)
    End If
End Function
Function GeoCoding(lat As Double, lng As Double) As String

    Dim XMLDoc As New DOMDocument
    Dim XMLNode As IXMLDOMNode
    Dim i As Long
    Dim mystring As String
    GeoCoding = False

    XMLDoc.Load "http://ws.geonames.org/findNearestAddress?lat=" & lat & "&lng=" & lng

    Do Until XMLDoc.ReadyState = 4
        DoEvents
    Loop

    If Len(XMLDoc.Text) = 0 Then
        GeoCoding = False
        Exit Function
    End If

    Set XMLNode = XMLDoc.selectSingleNode("//geonames/address")

    For i = 0 To XMLNode.childNodes.length - 1

        mystring = XMLNode.childNodes(i).baseName & ": " & XMLNode.childNodes(i).Text

    Next i

    GeoCoding = mystring

End Function
Function GetLatLonbyIP(Optional ipaddress As String) As String()
' returns IP, latitude and longitude for a given IP address
' returns latitude and longitude for current IP address if not specified

    Dim url As String
    Dim xml As Object  ' MSXML2.XMLHTTP60
    Dim XMLDoc As Object  ' MSXML2.DOMDocument60
    Dim items As Object  ' MSXML2.IXMLDOMNode
    Dim ip As Object  ' MSXML2.IXMLDOMNode
    Dim location As Object  ' MSXML2.IXMLDOMNode
    Dim coords As Object  ' MSXML2.IXMLDOMNode
    Dim lat As Object  ' MSXML2.IXMLDOMNode
    Dim lon As Object  ' MSXML2.IXMLDOMNode
    Dim latlon(1 To 3) As String

    Const BASE_URL As String = "http://geoip.prototypeapp.com/api/locate?format=xml"

    Set xml = GetMSXML
    Set XMLDoc = GetDomDoc
    If xml Is Nothing Then Exit Function
    If XMLDoc Is Nothing Then Exit Function

    ' build URL depending on whether IP was specified
    If Len(ipaddress) = 0 Then
        url = BASE_URL
    Else  ' add IP address
        url = BASE_URL & "&ip=" & ipaddress
    End If

    With xml
        .Open "GET", url
        .send
    End With

    ' load file into document object
    XMLDoc.loadXML xml.responseText

    ' walk the node hierarchy
    Set items = GetNode(XMLDoc, 2)
    ' first subnode contains IP address
    Set ip = GetNode(items, 1)
    ' location node contains lat and lon
    Set location = GetNode(items, 3)
    Set coords = GetNode(location, 1)
    Set lat = GetNode(coords, 1)
    Set lon = GetNode(coords, 2)

    latlon(1) = ip.nodeTypedValue
    latlon(2) = lat.nodeTypedValue
    latlon(3) = lon.nodeTypedValue

    GetLatLonbyIP = latlon

End Function

Comments