MS Access to KML Data Dump

Here’s a script that helps to export KML files for Google Earth from Access tables. The idea is that you create a query with columns named “Latitude” and “Longitude” and any other columns you need. Open that query, and pass the recordset to this dumper. You also specify a file name, and a list of columns to use for the name and definition fields.

The example is the testKML subroutine.

' rs is a regular recordset.  It must have a column named "Latitude" and another "Longitude".
' cols is a string with comma-separated column names that will be exported with the data.
' The first column is the title, and the rest form the description.
' http://code.google.com/apis/kml/documentation/
'<?xml version="1.0" encoding="UTF-8"?>
'<kml xmlns="http://www.opengis.net/kml/2.2">
'  <Placemark>
'    <name>Simple placemark</name>
'    <description>Attached to the ground. Intelligently places itself
'       at the height of the underlying terrain.</description>
'    <Point>
'      <coordinates>-122.0822035425683,37.42228990140251,0</coordinates>
'    </Point>
'  </Placemark>
'</kml>
Sub MakeKMLFromRecordset(ByVal fn As String, rs As Recordset, cols As String)
    Dim columns As Variant
    columns = Split(cols, ",")
    
    out = ""
    
    rs.MoveFirst
    While (Not rs.EOF)
        
        out = out & "<Placemark>"
        out = out & "<name>" & XMLEscape(rs.Fields(columns(0))) & "</name>"
        
        Description = ""
        For i = 1 To UBound(columns)
            Description = Description & rs.Fields(columns(i)) & " "
        Next i
        out = out & "<description>" & XMLEscape(Description) & "</description>"
        
        Point = "<coordinates>" & rs.Fields("Longitude") & "," & rs.Fields("Latitude") & "</coordinates>"
        out = out & "<Point>" & Point & "</Point>"
        
        out = out & "</Placemark>" & vbCrLf
        
        rs.MoveNext
    Wend
    out = "<kml xmlns=""http://www.opengis.net/kml/2.2""><Document>" & vbCrLf & out & "</Document></kml>"
    out = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf & out
    
    filenum = FreeFile()
    Open fn For Output As filenum
    Print #filenum, out
    Close #filenum
End Sub

Public Function XMLEscape(ByVal XMLin As String) As String
' http://miketurco.com/ms-access-vba-add-xml-escape-codes-102207
' replaces & " ' < and > with escape codes
   Dim g$
   g = XMLin
   g = Replace(g, "&", "&amp;")
   g = Replace(g, Chr(34), "&quot;")
   g = Replace(g, "'", "&apos;")
   g = Replace(g, "<", "&lt;")
   g = Replace(g, ">", "&gt;")
   XMLEscape = g
End Function

Sub testKML()
    Dim db As DAO.Database
    Set db = CurrentDb()
    
    Dim rs As DAO.Recordset
    qry = "qry Users with LatLon"
    Set rs = db.OpenRecordset(qry)
    
    filename = cmdExtFileDialog("kml")
    
    MakeKMLFromRecordset filename, rs, "OrgName,ACode,Phone"

End Sub

And here’s the code for the file dialog box helper.

Function cmdExtFileDialog(ext As String) As String

'Requires reference to Microsoft Office 10.0 Object Library.

   Dim fDialog As Office.FileDialog
   Dim fDialogFilter As Office.FileDialogFilter
   Dim varFile As Variant
   Dim path As String
   Dim filename As String

   'Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogSaveAs)
   With fDialog
      .AllowMultiSelect = False
      .title = "Save As " & UCase(ext) & "  File..."
      If .Show = True Then
         path = .InitialFileName
         filename = .SelectedItems.Item(1)
         If (LCase(Right(filename, 4)) <> "." & LCase(ext)) Then filename = filename & "." & ext
         cmdExtFileDialog = filename
         Exit Function
      Else
         Exit Function
      End If
   End With
End Function