Jeg har fundet denne:
http://code.google.com/p/access2kml/Måske er det løsningen, men det er svært for mig at finde ud af, da jeg ikke er god til vba. Koden ser således ud, men skal jo rettes til for mit projekt. Hvis en af jer kan lave en test.mdb med denne kode der virker, så vil det være lettere for mig at kopier det ind i mit projekt.
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
