Slovenian Postal Codes v. 2

In my previous blog post I gave a list of Slovenian postal codes based on a revision of an online source. Below I give you a Google based object oriented VBA solution, which easily generalizes to parsing of other xml sources. Geocoding can have an enormous impact on presentations and requires a careful processing. I use an automated VBA routine inspired by the code below, but still find that inspection is necessary. Often there are several loations of observations, businesses or respondents in a survey, that have to pinpointed using auxiliary information, which depends on the problem at hand. Have a look at www.hellmund-laier.dk

VBA module

Option Explicit Public xmlDoc As MSXML2.DOMDocument60

Public Function lat(searchfield As String) Dim googleUrl As String googleUrl = “http://maps.googleapis.com/maps/api/geocode/xml?address=” & searchfield & “&sensor=false” Set xmlDoc = New MSXML2.DOMDocument60 xmlDoc.async = False xmlDoc.Load (googleUrl) lat = xmlDoc.SelectSingleNode(“GeocodeResponse/result/geometry/location/lat”).Text End Function

Public Function lng(searchfield As String) lng = xmlDoc.SelectSingleNode(“GeocodeResponse/result/geometry/location/lng”).Text End Function

Example

A lng function call must follow a lat function call which instantiates the MSXML2.DOMDocument object.

In Excel with contents 1000,+Slovenia in cell A1, we place coordinate values in two separate cells using a single Google Map query  =lat(A1) superseeded by =lng(A1). The queries to the XML object return the values 46.0363798 and 14.4896074. To get things working you have to check Microsoft XML, v6.0 in the References… menu item found in the Tools menu of the VBA editor.

Supplementary note

I needed to convert a unicode input string to UTF-8 encoding. Below is the complete VBA module source including a converter suggested by Mycopka.

The UTF-8 encoded input string Forbindelsesvejen 116,+9400,+Nørresundby,+Denmark  returns values 57.0706070 and 9.9386770.

Source

Option Explicit

Public Declare PtrSafe Function WideCharToMultiByte Lib “kernel32” (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long

Public Declare PtrSafe Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Const m_bIsNt As Boolean = True

Public Const CP_UTF8 = 65001

Public xmlDoc As MSXML2.DOMDocument60

‘Purpose:Convert Unicode string to UTF-8.

Public Function UTF8_Encode(ByVal strUnicode As String, Optional ByVal bHTML As Boolean = True) As String

   Dim i                As Long

   Dim TLen             As Long

   Dim lPtr             As Long

   Dim UTF16            As Long

   Dim UTF8_EncodeLong  As String

   TLen = Len(strUnicode)

   If TLen = 0 Then Exit Function

   If m_bIsNt Then

      Dim lngBufferSize    As Long

      Dim lngResult        As Long

      Dim bytUtf8()        As Byte

      ‘Set buffer for longest possible string.

      lngBufferSize = TLen * 3 + 1

      ReDim bytUtf8(lngBufferSize – 1)

      ‘Translate using code page 65001(UTF-8).

      lngResult = WideCharToMultiByte(CP_UTF8, 0, StrPtr(strUnicode), _

         TLen, bytUtf8(0), lngBufferSize, vbNullString, 0)

      ‘Trim result to actual length.

      If lngResult Then

         lngResult = lngResult – 1

         ReDim Preserve bytUtf8(lngResult)

         ‘CopyMemory StrPtr(UTF8_Encode), bytUtf8(0&), lngResult

         UTF8_Encode = StrConv(bytUtf8, vbUnicode)

         ‘ For i = 0 To lngResult

         ‘    UTF8_Encode = UTF8_Encode & Chr$(bytUtf8(i))

         ‘ Next

      End If

   Else

      For i = 1 To TLen

         ‘ Get UTF-16 value of Unicode character

         lPtr = StrPtr(strUnicode) + ((i – 1) * 2)

         CopyMemory UTF16, ByVal lPtr, 2

         ‘Convert to UTF-8

         If UTF16 < &H80 Then                                      ' 1 UTF-8 byte

            UTF8_EncodeLong = Chr$(UTF16)

         ElseIf UTF16 < &H800 Then                                 ' 2 UTF-8 bytes

            UTF8_EncodeLong = Chr$(&H80 + (UTF16 And &H3F))              ‘ Least Significant 6 bits

            UTF16 = UTF16 \ &H40                                   ‘ Shift right 6 bits

            UTF8_EncodeLong = Chr$(&HC0 + (UTF16 And &H1F)) & UTF8_EncodeLong  ‘ Use 5 remaining bits

         Else                                                      ‘ 3 UTF-8 bytes

            UTF8_EncodeLong = Chr$(&H80 + (UTF16 And &H3F))              ‘ Least Significant 6 bits

            UTF16 = UTF16 \ &H40                                   ‘ Shift right 6 bits

            UTF8_EncodeLong = Chr$(&H80 + (UTF16 And &H3F)) & UTF8_EncodeLong  ‘ Use next 6 bits

            UTF16 = UTF16 \ &H40                                   ‘ Shift right 6 bits

            UTF8_EncodeLong = Chr$(&HE0 + (UTF16 And &HF)) & UTF8_EncodeLong   ‘ Use 4 remaining bits

         End If

         UTF8_Encode = UTF8_Encode & UTF8_EncodeLong

      Next

   End If

   ‘Substitute vbCrLf with HTML line breaks if requested.

   If bHTML Then

      UTF8_Encode = Replace$(UTF8_Encode, vbCrLf, “”)

   End If

End Function

Public Function lat(searchfield As String)

Dim googleUrl As String

googleUrl = “http://maps.googleapis.com/maps/api/geocode/xml?address=&#8221; & UTF8_Encode(searchfield) & “&sensor=false”

Set xmlDoc = New MSXML2.DOMDocument60

xmlDoc.async = False

xmlDoc.Load (googleUrl)

lat = xmlDoc.SelectSingleNode(“GeocodeResponse/result/geometry/location/lat”).Text

End Function

Public Function lng(searchfield As String)

lng = xmlDoc.SelectSingleNode(“GeocodeResponse/result/geometry/location/lng”).Text

End Function