テーブルをXML形式で出力する方法

Access2000には、テーブルのデータをXML形式で出力する そのものずばりの機能があります。

    Dim rcd As New ADODB.Recordset
    rcd.Open "テーブル", CurrentProject.Connection, adOpenStatic, adLockReadOnly
    rcd.Save "c:\save.xml", adPersistXML
    rcd.Close

ただしこの方法では、項目の定義やら何やらをこまごまと出力してくれる割には 肝心のデータ部分がいまいち使いづらい形をしています。 こんな感じで。

そこで、単純なXML形式で出力するようなサブルーチンを作ってみました。

Sub XmlOut(tblname As String, filepath As String, filename As String, roottag As String, xsl As Boolean)

    Dim fno As Long
    fno = FreeFile()
    Open filepath & filename & ".xml" For Output As #fno
'ヘッダー部
    Print #fno, "<?xml version=""1.0"" encoding=""Shift_JIS""?>"
    Dim t As String
    If xsl Then t = " href=""" & filename & ".xsl"""
    Print #fno, "<?xml-stylesheet type=""text/xsl""" & t & "?>"
    Print #fno, "<" & roottag & "全体>"

    Dim rcd As New ADODB.Recordset
    rcd.Open tblname, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

'テーブルの全項目名を取得
    Dim fld As Field, fldct As Integer
    fldct = rcd.Fields.Count
    Dim fldname() As String
    ReDim fldname(fldct)
    Dim i As Integer
    For i = 1 To fldct
        fldname(i) = rcd.Fields(i - 1).Name
    Next

'各レコードの処理
    Do While Not rcd.EOF
        Print #fno, "<" & roottag & "詳細>"
        For i = 1 To fldct
            Dim val As Variant
            val = rcd(fldname(i)).Value
            If IsNull(val) Then val = ""
            Print #fno, "<" & fldname(i) & ">" & val & "</" & fldname(i) & ">";
        Next
        Print #fno, ""
        Print #fno, "</" & roottag & "詳細>"
        rcd.MoveNext
    Loop

    rcd.Close

'フッター部
    Print #fno, "</" & roottag & "全体>"
    Close #fno

End Sub

使い方は次のようになります。 こんな感じで出力されます。

    Call XmlOut("テーブル", "c:\", "org", "テスト", False)

ちなみに、サンプルに使ったテーブルは以下のようなものです。