kml export

bosstec

New Member
Joined
Jun 23, 2011
Messages
12
Hi

I need to make a function to export to kml (google maps).
I have the Longitude and Latitude values for each record, together with additional information (description ect), and I also need to format the pins according to the status of each record.

I found this code on the web, but I am not sure how to make table and a simple form to test the function. I do even not know if this is working for me. Maybe some of you can help me a little further.

I am using Access 2010


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 = "country" ' FIELD NAME TO BE GROUPED ON
difffiles = False ' DIFERENT FILES TO EACH GROUP
visibility = False ' AUTOMATIC SHOWING OR NOT

' GENERAL CONFIGURATION
filepath = CurrentProject.Path ' SAME PATH AS THE MDB
filename = "GeoNamesAVG" ' OUTPUT FILE NAME
docname = "Africa Database" ' KML TITLE AND FOLDER NAME
databasename = "GeoNamesAVGq" ' 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 MINUTS
cfieldName = "full_name" ' NAME OF THE SITE
cfieldLat = "lat" ' LATITUDE
cfieldLong = "long" ' LONGITUDE
cfieldAlt = "" ' ALTITUDE
cfieldDesc = "sort_name" ' 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 DEFFINED 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
If (rs.Fields(i).Name = cfieldLat) Then latitude = rs.Fields(i).Value
If (rs.Fields(i).Name = cfieldLong) Then longitude = rs.Fields(i).Value
If (rs.Fields(i).Name = cfieldAlt) Then altitude = rs.Fields(i).Value
If (rs.Fields(i).Name = cfieldDesc) Then description = rs.Fields(i).Value
If (rs.Fields(i).Name = cfieldCoun) Then country = rs.Fields(i).Value
If (rs.Fields(i).Name = cfieldRange) Then range = rs.Fields(i).Value
If (rs.Fields(i).Name = cfieldTilt) Then tilt = rs.Fields(i).Value
If (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
 

Some videos you may like

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

Watch MrExcel Video

Forum statistics

Threads
1,122,469
Messages
5,596,313
Members
414,052
Latest member
Dual Showman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top