VBA Access: organize assorted records into KML folders

Question

I'm creating a program in Access that exports a table with coordinates into a view-able KML file. Currently the code I'm using starts at the beginning of the recordset and individually prints each record into a KML file.

However I'm wanting to have the code organize the records into folders (based on week they were created) on the KML file. The only way I could find to code folders into a KML file requires me to nest the entries into specific parts of the code. Since I'm writing my records from top to bottom and they're not in the order I want them to be sorted in it is causing a problem.

I'm pretty new to VBA and the only way I could figure to get around this would be to pass through my record set several times, and each time check for a different week, so I could write it to the correct position in the KML file. The database is rather large though and I feel like there should be an easier or cleaner way to do this.

Any help or suggestions is appreciated. My current code (just the section that writes to the KML)

Open strSavePath For Output Shared As #1

'init KML file
Print #1, "<?xml version=""1.0"" encoding=""UTF-8""?>"
Print #1, "<kml xmlns=""http://www.opengis.net/kml/2.2"">"
Print #1, "<Document>"
'create plot styles
Print #1, "<Style id=""K1res"">"
Print #1, "<IconStyle> <color>ff14F0FF</color> <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon57.png</href></Icon></IconStyle>"
Print #1, "</Style>"

Print #1, "<Style id=""K1com"">"
Print #1, "<IconStyle> <color>FF1473FF</color> <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon57.png</href></Icon></IconStyle>"
Print #1, "</Style>"

With MyRS
Do Until .EOF
Print #1, "   <Placemark>"
If Me.boxPlotTitle.Value = True Then
Print #1, "      <name>" & DateShort(MyRS.Fields(4)) & "</name>"
End If

Print #1, "      <description>" & CleanupStr(MyRS.Fields(8)) & vbNewLine & vbNewLine & "Date: " & MyRS.Fields(4) & "</description>"



If MyRS.Fields(6) = "Residential" Then
    Print #1, "      <styleUrl>#K1res</styleUrl>  "
Else
    Print #1, "      <styleUrl>#K1com</styleUrl>  "
End If

Print #1, "      <Point>"
strText = "         <coordinates>" & MyRS.Fields(11) & "," & MyRS.Fields(10) & "</coordinates>"
Print #1, strText
Print #1, "      </Point>"
Print #1, "   </Placemark>"
.MoveNext
Loop
End With

Print #1, "</Document>"
Print #1, "</kml>"

Egress:
On Error Resume Next
Close #1
MyRS.Close
Set MyRS = Nothing
Set MyDB = Nothing

MsgBox "Successfully Exported KML"
Call Shell("explorer.exe " & strSavePath, vbNormalFocus)

Exit Sub

ErrHandler:
MsgBox Err.Description
Resume Egress

End Sub

Answer 1

First, KML is a special XML file. And Access can export table and query data into XML format. So you can easily export your coordinates data into XML without iterating through a recordset:

Application.ExportXML acExportQuery, "yourtableorqueryname", "\path\to\file.xml"

However, KML requires special headers which need to be incorporated with your coordinates data. With that, you can consider using an xsl stylesheet with the VBA's MSXML object to transform it (basically append the query output into the KML shell):

XML FILE (TO BE TRANSFORMED)

<?xml version="1.0" encoding="UTF-8"?>
<kml>
    <Document>
        create plot styles
        <Style id="K1res">
            <IconStyle> <color>ff14F0FF</color> <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon57.png</href></Icon></IconStyle>
        </Style>
        <Style id="K1com">
            <IconStyle> <color>FF1473FF</color> <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon57.png</href></Icon></IconStyle>
        </Style>

    <Dataroot>

    </Dataroot>

    </Document>
</kml>

XSL (TRANSFORMATION STYLESHEET)

<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
<xsl:output version="1.0" encoding="UTF-8"/>

    <xsl:template match="@*|node()">
        <xsl:copy>
            <xsl:apply-templates select="@*|node()"/><xsl:text>&#xA;</xsl:text><xsl:text>&#xA;</xsl:text>  
        </xsl:copy>
    </xsl:template>

    <xsl:template match='//Document/Dataroot'>        
            <xsl:copy-of select="document('yourtablequeryoutput.xml')/Placemark"/><xsl:text>&#xA;</xsl:text>        
    </xsl:template>


</xsl:transform>

ACCESS VBA (TRANSFORMING, SAVING OUTPUT)

''IN REFERENCE LIBRARY SELECT THE Microsoft XML, v3.0
Dim xmlfile As New MSXML2.DOMDocument   
Dim xslfile As New MSXML2.DOMDocument    
Dim newXMLDoc As New MSXML2.DOMDocument 

Application.ExportXML acExportQuery, "yourtableorqueryname", "\path\to\file.xml"

xmlfile.SetProperty "AllowDocumentFunction", True
xmlfile.async = False
xmlfile.Load "\path\to\abovexmlfiletobetransformed.xml"


xslfile.SetProperty "AllowDocumentFunction", True
xslfile.async = False
xslfile.Load "\path\to\abovexslfilethattransforms.xsl"


xmlfile.transformNodeToObject xslfile, newXMLDoc
newXMLDoc.Save "\path\to\finaloutput.xml"