Attribute VB_Name = "XML"
Option Compare Database
Option Explicit

Sub QFN(MyQName As String, WithFormats As Byte)
Dim MyDb As Database, TDefLoop As QueryDef, MySet As Recordset, MyFormat() As String
Dim FNames() As String, n As Integer, MyF As Field, Tt As String, NumF As Integer
Set MyDb = CurrentDb()

For Each TDefLoop In MyDb.QueryDefs
  If TDefLoop.Name = MyQName Then
   Debug.Print "List of fields in '" & UCase(TDefLoop.Name) & "'"
   NumF = TDefLoop.Fields.Count - 1
   ReDim FNames(NumF)
   ReDim MyFormat(NumF)
   Debug.Print Format(NumF + 1, "0") & " fields, " & Format(Date, "dd/mm/yy")

   For n = 0 To NumF
    Set MyF = TDefLoop.Fields(n)
    
        Select Case MyF.Type
            Case 2
            Tt = "Byte"
            MyFormat(n) = "0"
            Case 3
            MyFormat(n) = "#,##0;(#,##0)"
            Tt = "Integer"
            Case 4
            Tt = "Long"
            MyFormat(n) = "#,##0;(#,##0)"
            Case 5
            Tt = "Currency"
            MyFormat(n) = "£#,##0;(£#,##0)"
            Case 6
            Tt = "Single"
            MyFormat(n) = "#,##0;(#,##0)"
            Case 7
            Tt = "Double"
            MyFormat(n) = "#,##0;(#,##0)"
            Case 8
            Tt = "Date"
            MyFormat(n) = "dd/mm/yy"
            Case 10
            Tt = "Text"
            MyFormat(n) = "T"
            Case 12
            Tt = "Memo"
            MyFormat(n) = "T"
        
        Case Else
        Tt = "Not known"
        MyFormat(n) = "T"
        End Select
        
        If InStr(1, MyF.Name, "WTE") > 0 Then
         MyFormat(n) = "#,##0.00;(#,##0.00)"
        End If
        
     Debug.Print n + 1 & ". " & MyF.Name & " (" & Tt & ") > " & MyFormat(n)
     FNames(n) = MyF.Name   ', MyF.Size, MyF.SourceTable
     
     Next n
    End If
Next TDefLoop

Set MySet = MyDb.OpenRecordset(MyQName, dbOpenDynaset)
Open "c:\MyXMLtest.xml" For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "ISO-8859-1" & Chr(34) & "?>"
Print #1, "<" & FillSpaces(MyQName) & ">"

MySet.MoveFirst
Do Until MySet.EOF
 Print #1, "<mydata>"
    For n = 0 To NumF
    If MyFormat(n) = "T" Or WithFormats = 0 Then
    Tt = RemoveAmpersands(MySet.Fields(n).Value) ' The & character is not allowed in XML
     Else
    Tt = Format(MySet.Fields(n).Value, MyFormat(n))
    End If
    
     Print #1, "<" & FillSpaces(FNames(n)) & ">" & Tt & "</" & FillSpaces(FNames(n)) & ">"
    Next n
 Print #1, "</mydata>"
MySet.MoveNext
Loop

Print #1, "</" & FillSpaces(MyQName) & ">"
Close #1
MySet.Close
MyDb.Close
End Sub

Function FillSpaces(AnyStr As String) As String
' replace spaces with underscores
Dim MyPos As Integer

MyPos = InStr(1, AnyStr, " ")
Do While MyPos > 0
 Mid(AnyStr, MyPos, 1) = "_"
 MyPos = InStr(1, AnyStr, " ")
Loop
FillSpaces = LCase(AnyStr)
End Function

Function RemoveAmpersands(AnyStr As String) As String
Dim MyPos As Integer
' replace Ampersands (&) with plus symbols (+)

MyPos = InStr(1, AnyStr, "&")
Do While MyPos > 0
 Mid(AnyStr, MyPos, 1) = "+"
 MyPos = InStr(1, AnyStr, "&")
Loop
RemoveAmpersands = AnyStr
End Function