AccessToKML

Option Compare Database


Public Sub generateKML()
'
' GenerateKML Macro
' Macro recorded 26/09/2006 by simon_a
' Adapted and imported to Access by SAA
' 03 aug 2007 - v3.0 - 2007 08 06 19 24
'

    ' DECLARE VARIABLES
    Dim filename As String
    Dim docname As String

    Dim altitude As String
    Dim range As String
    Dim tilt As String
    Dim heading As String
    Dim description As String
    Dim visibility As Boolean

    Dim grouping As Boolean
    Dim grpfield As String
    Dim grpfilter As String

    Dim cfieldName As String
    Dim cfieldLat As String
    Dim cfieldLong As String
    Dim cfieldAlt As String
    Dim cfieldDesc As String
    Dim cfieldCoun As String
    Dim cfieldRange As String
    Dim cfieldTilt As String

    Dim identa As Integer
    identa = 0

    ' GROUPING CONFIGURATION
    ' CREATE A SEPARTE SUBFOLDER TO EACH GROUP
    grouping = True ' GROUPING TROU OR FALSE
    grpfield = "Group" ' FIELD NAME TO BE GROUPED ON
    difffiles = False     ' DIFERENT FILES TO EACH GROUP
    visibility = False    ' AUTOMATIC SHOWING OR NOT

    ' GENERAL CONFIGURATION
    filePath = "C:\Users\james\Desktop\In Development" ' SAME PATH AS THE MDB
    filename = "QueryOutput" ' OUTPUT FILE NAME
    docname = "MapDB Query Results" ' KML TITLE AND FOLDER NAME
    databasename = CurrentDb!Queries!qryDataExport ' SOURCE TABLE OR QUERY

    ' RESPECTIVE COLLUM NAMES RELATIVE TO EACH FILTER
    ' REMEMBER THAT LAT AND LONG MUST BE IN DEC OF DEGREE
    ' AND NOT IN MINUTES
    cfieldName = "Map_Number" ' NAME OF THE SITE
    cfieldLat = "latitude"        ' LATITUDE
    cfieldLong = "longitude"      ' LONGITUDE
    cfieldAlt = ""           ' ALTITUDE
    cfieldDesc = "Map_Type" ' DESCRIPTION
    cfieldCoun = "country"   ' COUNTRY
    cfieldRange = ""         ' RANGE
    cfieldTilt = ""          ' TILT

    ' VALUES IF NOT DEFINED IN THE TABLE
    ' IF FIND IN THE TABLE THE DEFAULT VALUE
    ' WILL BE ERASED
    altitude = "0"
    range = "68424.19526792552"
    tilt = "2.022197391423853e-010"
    heading = "-0.02880169675294712"

    ' OPEN DATABASE
    Dim outputtext As Collection
    Set outputtext = New Collection

    ' OPEN DATABASE
    Dim rs As DAO.Recordset

    ' GROUPING
    If grouping Then
        ' CREATES A KEY LIST
        Dim keys As DAO.Recordset
        groupcmd = "SELECT [" & databasename & "].[" & grpfield & "] FROM [" & databasename & "] GROUP BY [" & databasename & "].[" & grpfield & "]"
        identa = 1
        Set keys = CurrentDb.OpenRecordset(groupcmd, dbOpenSnapshot)

        If Not (difffiles) Then
            ' OPEN FILE
            Close #1
            file = filePath & "\" & filename & ".kml"
            Open file For Output As #1

            ' WRITING KML HEADER
            Set outputtext = kmlheader(filename, docname, visibility)
        End If

        If Not (keys.BOF And keys.EOF) Then ' There is data
            keys.MoveFirst
            Do Until keys.EOF = True
                grpfilter = keys.Fields(0).Value
                'IS DEFINED TO SEPARATE IN DIFFERENT FOLDERS, CREATE A FOLDER LIST
                If (difffiles) Then
                    ' OPEN FILE
                    Close #1
                    Dim tmpfilename As String
                    Dim tmpdocname As String

                    tmpfilename = filename & "_" & grpfilter & ".kml"
                    tmpdocname = docname & "_" & grpfilter
                    file = filePath & "\" & tmpfilename
                    Open file For Output As #1

                    ' WRITING KML HEADER
                    Set outputtext = kmlheader(tmpfilename, tmpdocname, visibility)
                End If

                ident1 = ident(identa + 1)
                ident2 = ident(identa + 2)

                outputtext.Add Item:=ident1 & "<Folder>"
                outputtext.Add Item:=ident2 & "<name>" & grpfilter & "</name>"
                outputtext.Add Item:=ident2 & "<open>0</open>"
                If visibility Then strvisible = "1" Else strvisible = "0"
                outputtext.Add Item:=ident2 & "<visibility>" & strvisible & "</visibility>"

                Set outputtext = printerpart(outputtext)

                record2open = "SELECT * FROM " & databasename & " WHERE [" & grpfield & "] = """ & grpfilter & """"
                Set rs = CurrentDb.OpenRecordset(record2open, dbOpenSnapshot)
                Set outputtext = gatherData(rs, cfieldName, cfieldLat, cfieldLong, cfieldAlt, cfieldDesc, cfieldCoun, cfieldRange, cfieldTilt, altitude, range, tilt, heading, description, identa)

                outputtext.Add Item:=ident1 & "</Folder>"
                Set outputtext = printerpart(outputtext)

                keys.MoveNext
                rs.Close
            Loop
        End If
        keys.Close
    Else
        Set rs = CurrentDb.OpenRecordset(databasename)
        identa = 0

        ' OPEN FILE
        Close #1
        Open filePath & "\" & filename & ".kml" For Output As #1

        ' WRITING KML HEADER
        Set outputtext = kmlheader(filename, docname, visibility)

        ' GATHERING DATA AND PRITING PLACEMARK WITHOUT FILTER
        Set outputtext = gatherData(rs, cfieldName, cfieldLat, cfieldLong, cfieldAlt, cfieldDesc, cfieldCoun, cfieldRange, cfieldTilt, altitude, range, tilt, heading, description, identa)
        rs.Close
    End If

    ' WRITING FOOTER OF KML
    Set outputtext = footer()
    Close #1
End Sub

Function ident(identa As Integer) As String
    Dim identation As String
    identation = String(identa, vbTab)
    ident = identation
End Function

Function printerpart(outputtext As Collection) As Collection
    TotalRecords = outputtext.Count
    For i = 1 To TotalRecords
        outputext = outputtext(i)
        outputext = Replace(outputext, "&", "and")
        Print #1, outputext
    Next i
    Set printerpart = New Collection
End Function


Function gatherData(rs As Recordset, cfieldName As String, cfieldLat As String, cfieldLong As String, cfieldAlt, cfieldDesc As String, cfieldCoun As String, cfieldRange As String, cfieldTilt As String, altitude As String, range As String, tilt As String, heading As String, description As String, identa As Integer) As Collection
    Dim outputtext As Collection
    Set outputtext = New Collection
    Dim locationname As String
    Dim Longitude As String
    Dim Latitude As String

    ' GATHERING THE ACTUAL DATA
    If Not (rs.BOF And rs.EOF) Then ' There is data
        rs.MoveFirst
        Do Until rs.EOF = True
            For i = 0 To rs.Fields.Count - 1
                If (rs.Fields(i).Name = cfieldName) Then locationname = rs.Fields(i).Value
                ElseIf (rs.Fields(i).Name = cfieldLat) Then Latitude = rs.Fields(i).Value
                ElseIf (rs.Fields(i).Name = cfieldLong) Then Longitude = rs.Fields(i).Value
                ElseIf (rs.Fields(i).Name = cfieldAlt) Then altitude = rs.Fields(i).Value
                ElseIf (rs.Fields(i).Name = cfieldDesc) Then description = rs.Fields(i).Value
                ElseIf (rs.Fields(i).Name = cfieldCoun) Then country = rs.Fields(i).Value
                ElseIf (rs.Fields(i).Name = cfieldRange) Then range = rs.Fields(i).Value
                ElseIf (rs.Fields(i).Name = cfieldTilt) Then tilt = rs.Fields(i).Value
                ElseIf (rs.Fields(i).Name = cfieldhead) Then heading = rs.Fields(i).Value
            Next i

        ' WRITING THE PLACEMARK PART OF THE KML
        Set outputtext = placemark(locationname, Longitude, Latitude, altitude, range, tilt, heading, description, identa)
        rs.MoveNext
        Loop
    End If

    Set gatherData = printerpart(outputtext)
End Function

Function footer() As Collection
    Dim outputtext As Collection
    Set outputtext = New Collection
    identa = 0

    outputtext.Add Item:=ident(identa + 1) & "</Folder>"
    outputtext.Add Item:="</Document>"
    outputtext.Add Item:="</kml>"
    Set footer = printerpart(outputtext)
End Function

Function placemark(locationname As String, Longitude As String, Latitude As String, altitude As String, range As String, tilt As String, heading As String, description As String, identa As Integer) As Collection
    Dim outputtext As Collection
    Set outputtext = New Collection
    ' WRITE PLACEMARK TO EACH SITE

    ' IDENTATION
    ident2 = ident(identa + 2)
    ident3 = ident(identa + 3)
    ident4 = ident(identa + 4)

    outputtext.Add Item:=ident2 & "<Placemark>"
    outputtext.Add Item:=ident3 & "<name>" & locationname & "</name>"
    outputtext.Add Item:=ident3 & "<LookAt>"
    outputtext.Add Item:=ident4 & "<longitude>" & Longitude & "</longitude>"
    outputtext.Add Item:=ident4 & "<latitude>" & Latitude & "</latitude>"
    outputtext.Add Item:=ident4 & "<altitude>" & altitude & "</altitude>"
    outputtext.Add Item:=ident4 & "<range>" & range & "</range>"
    outputtext.Add Item:=ident4 & "<tilt>" & tilt & "</tilt>"
    outputtext.Add Item:=ident4 & "<heading>" & heading & "</heading>"
    outputtext.Add Item:=ident4 & "<altitudeMode>relativeToGround</altitudeMode>"
    outputtext.Add Item:=ident3 & "</LookAt>"
    outputtext.Add Item:=ident3 & "<styleUrl>#msn_pin</styleUrl>"
    outputtext.Add Item:=ident3 & "<Point>"
    outputtext.Add Item:=ident4 & "<coordinates>" & Longitude & "," & Latitude & ",0</coordinates>"
    outputtext.Add Item:=ident3 & "</Point>"
    outputtext.Add Item:=ident3 & "<description><![CDATA[" & description & "]]></description>"
    outputtext.Add Item:=ident2 & "</Placemark>"

    Set placemark = printerpart(outputtext)
End Function

Function kmlheader(filename As String, docname As String, visibility As Boolean) As Collection
    Dim outputtext As Collection
    Set outputtext = New Collection
    identa = 0
    ' WRITING KML HEADER

    ' INDENTATION
    ident1 = ident(identa + 1)
    ident2 = ident(identa + 2)
    ident3 = ident(identa + 3)
    ident4 = ident(identa + 4)

    ' TEXT ITSELF
    outputtext.Add "<?xml version=""1.0"" encoding=""UTF-8""?>"
    outputtext.Add Item:="<kml xmlns=""http://earth.google.com/kml/2.0"">"
    outputtext.Add Item:="<Document>"

    outputtext.Add Item:=ident1 & "<name>" & filename & "</name>"

    outputtext.Add Item:=ident1 & "<Style id=""sn_pin"">"
    outputtext.Add Item:=ident2 & "<IconStyle>"
    outputtext.Add Item:=ident3 & "<scale>1.1</scale>"
    outputtext.Add Item:=ident3 & "<Icon>"
    outputtext.Add Item:=ident4 & "<href>http://maps.google.com/mapfiles/kml/pal2/icon13.png</href>"
    outputtext.Add Item:=ident3 & "</Icon>"
    outputtext.Add Item:=ident3 & "<hotSpot x=""20"" y=""2"" xunits=""pixels"" yunits=""pixels""/>"
    outputtext.Add Item:=ident2 & "</IconStyle>"
    outputtext.Add Item:=ident1 & "</Style>"

    outputtext.Add Item:=ident1 & "<Style id=""sh_pin"">"
    outputtext.Add Item:=ident2 & "<IconStyle>"
    outputtext.Add Item:=ident3 & "<scale>1.5</scale>"
    outputtext.Add Item:=ident3 & "<Icon>"
    outputtext.Add Item:=ident4 & "<href>http://maps.google.com/mapfiles/kml/pal2/icon13.png</href>"
    outputtext.Add Item:=ident3 & "</Icon>"
    outputtext.Add Item:=ident3 & "<hotSpot x=""20"" y=""2"" xunits=""pixels"" yunits=""pixels""/>"
    outputtext.Add Item:=ident2 & "</IconStyle>"
    outputtext.Add Item:=ident1 & "</Style>"

    outputtext.Add Item:=ident1 & "<StyleMap id=""msn_pin"">"
    outputtext.Add Item:=ident2 & "<Pair>"
    outputtext.Add Item:=ident3 & "<key>normal</key>"
    outputtext.Add Item:=ident3 & "<styleUrl>#sn_pin</styleUrl>"
    outputtext.Add Item:=ident2 & "</Pair>"
    outputtext.Add Item:=ident2 & "<Pair>"
    outputtext.Add Item:=ident3 & "<key>highlight</key>"
    outputtext.Add Item:=ident3 & "<styleUrl>#sh_pin</styleUrl>"
    outputtext.Add Item:=ident2 & "</Pair>"
    outputtext.Add Item:=ident1 & "</StyleMap>"

    outputtext.Add Item:=ident1 & "<Folder>"
    outputtext.Add Item:=ident2 & "<name>" & docname & "</name>"

    outputtext.Add Item:=ident2 & "<open>0</open>"

    If visibility Then strvisible = "1" Else strvisible = "0"
    outputtext.Add Item:=ident2 & "<visibility>" & strvisible & "</visibility>"

    Set kmlheader = printerpart(outputtext)
End Function