Accessから複数のテーブルを1つのXMLファイルにエクスポート

Question

このコードでAccessから1つのテーブルのみをエクスポートできます。

Option Compare Database 

Function ExportXML() 

'Init root xml 
Dim objDom As DOMDocument 
Set objDom = New DOMDocument 

Dim objRootElem As IXMLDOMElement 
Set objRootElem = objDom.createElement("root") 
objDom.appendChild objRootElem 

Dim objChartElem As IXMLDOMElement 
Set objChartElem = objDom.createElement("charts") 
objRootElem.appendChild objChartElem 
'At this point we will have root->charts 

'Get current database file 
Dim db As Database 
Set db = CurrentDb 

'Construct query 
Dim strSQL As String 
strSQL = "select * from TestTable" 

'Get result set 
Dim rs As DAO.Recordset 
Set rs = db.OpenRecordset(strSQL) 

'Create chartEntry in xml 
Dim objSpecificChartElem As IXMLDOMElement 
Set objSpecificChartElem = objDom.createElement("chart") 
objChartElem.appendChild objSpecificChartElem 

' Creates Attribute to the Member Element 
Set objKeyRel = objDom.createAttribute("Key") 
objKeyRel.nodeValue = "TestTable" 'Value corresponds to table name 
objSpecificChartElem.setAttributeNode objKeyRel 

'Looping through each row 
Do While Not rs.EOF 
    'Current row 

    'Create entry in specific chart element 
    Dim objRowElem As IXMLDOMElement 
    Set objRowElem = objDom.createElement("col") 
    objSpecificChartElem.appendChild objRowElem 

    'We skip the ID column 
    For i = 1 To rs.Fields.Count - 1 
     'Each field 

     Dim objColElem As IXMLDOMElement 
     Set objColElem = objDom.createElement("string") 'Add logic to determine datatype 
     objRowElem.appendChild objColElem 

     'Extract value and add to element 
     Set objColValue = objDom.createAttribute("val") 
     objColValue.nodeValue = rs.Fields(i).Value 
     objColElem.setAttributeNode objColValue 

    Next i 

    'Next 
    rs.MoveNext 
Loop 

'Save 
Dim path As String 
path = CurrentDb.Name & ".export.xml" 
objDom.Save (path) 

'Show success 
MsgBox "Succesfully exported at: " & path, vbDefaultButton1, "Export" 


End Function 

このコードのフォーマットは使用できますが、複数のテーブルを1つのXMLファイルにエクスポートするにはどうすればよいですか？

XML出力は次のようになります。

<?xml version="1.0" encoding="UTF-8"?> 
<root>  
<charts>   
<chart key="testtable">    
<col>     
<string val="quarter"/>     
<string val="Q1"/>     
<string val="Q2"/>     
<string val="Q3"/>     
<string val="Q4"/>    
</col>    
<col>     
<string val="Group 1"/>     
<double val="100.1"/>     
<double val="200.6"/>     
<double val="250"/>     
<double val="300.8"/>    
</col>    
<col>     
<string val="Group 2"/>     
<double val="250"/>     
<double val="100.1"/>     
<double val="300.8"/>     
<double val="200.6"/>    
</col>    
<col>     
<string val="growth"/>     
<double val="22.5"/>     
<double val="-5.1"/>     
<double val="3.8"/>     
<double val="50.6"/>    
</col>   
</chart>   
<chart key="halfyear">    
<col>     
<string val="Period"/>     
<string val="spring"/>     
<string val="winter"/>    
</col>    
<col>     
<string val="numbers"/>     
<double val="50"/>     
<double val="150"/>    
</col>    
<col>     
<string val="price"/>     
<double val="8.3"/>     
<double val="1.2"/>    
</col>    
<col>      
<string val="difference"/>     
<double val="0"/>     
<double val="-7"/>    
</col>   
</chart>  
</charts> 
</root> 

これは、テーブルがどのように見えるべきかです：

Answer 1

は繰り返し渡されたパラメータを使用してExportXML()関数を呼び出し、TableDefsコレクションを使用して、データベースのすべてのテーブルをループ考えてみましょう。同時に、後ですべての結果XMLファイルを1つのマスターファイルにバインドするための特別なXSLTスクリプトを作成します。

情報として、XSLTは、XMLファイルを変換するために設計された特別な目的の言語であり、そのdocument()機能を使用して外部のXMLをインポートすることができます。 XSLTは、他のXMLファイルのディレクトリを読み込む必要があるため、ディスクに保存してメモリで使用しないでください。

XSLTモデル

（動的に以下のコードに内蔵されているスクリプト、それはVBAの元の変換元であるので、第一Table1.xmlに気付か宣言されていない）

<xsl:transform xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0"> 
    <xsl:output version="1.0" encoding="UTF-8" indent="yes" method="xml"/> 
    <xsl:strip-space elements="*"/> 

    <xsl:template match="/"> 
    <root> 
     <xsl:copy-of select="*"/> 
     <xsl:copy-of select="document('Table2.xml')/root/*"/> 
     <xsl:copy-of select="document('Table3.xml')/root/*"/> 
     <xsl:copy-of select="document('Table4.xml')/root/*"/> 
     ... 
     <xsl:copy-of select="document('Tabl50.xml')/root/*"/> 
    </root> 
    </xsl:template> 
</xsl:transform 

VBA

（テーブル名のパラメータで元の関数を使用して） 10

Public Function ExportXML(tblname As String) 
    '...same exact code with following line changes... 

    strSQL = "select * from [" & tblname & "]" 
    '... 
    path = Application.CurrentProject.Path & "\" & tblname & ".xml" 

    ' REMOVE SUCCESS MSGBOX 
End Function 

Public Sub MasterXMLFile() 
On Error GoTo ErrHandle 
    ' ADD VBA REFERENCE: MSXML, v6.0 
    Dim xmlDoc As New MSXML2.DOMDocument60, xslDoc As New MSXML2.DOMDocument60, newDoc As New MSXML2.DOMDocument60 
    Dim xslstr As String, firstXML As String 
    Dim tbl As TableDef 
    Dim i As Integer: i = 1 

    ' START XSLT 
    xslstr = "<xsl:transform xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"" version=""1.0"">" _ 
        & " <xsl:output version=""1.0"" encoding=""UTF-8"" indent=""yes"" method=""xml""/>" _ 
        & " <xsl:strip-space elements=""*""/>" _ 
        & " " _ 
        & " <xsl:template match=""/"">" _ 
        & "  <root>" _ 
        & "  <xsl:copy-of select=""*""/>" 

    For Each tbl In CurrentDb.TableDefs 
     If i = 1 Then firstXML = tbl.Name 
     ' CALL ORIGINAL FUNCTION 
     Call ExportXML(tbl.Name) 

     ' CONCATENATE XSLT STRING 
     xslstr = xslstr & " <xsl:copy-of select=""document('" & tbl.Name & ".xml')/root/*""/>" 
     i = i + 1  
    Next tbl 

    ' END XSLT 
    xslstr = xslstr & "  </root>" _ 
        & " </xsl:template>" _ 
        & " " _ 
        & "</xsl:transform>" 

    xslDoc.loadXML xslstr 
    xslDoc.Save Application.CurrentProject.Path & "\MasterFile.xsl" 

    ' LOAD FIRST XML AND XSL 
    xmlDoc.Load Application.CurrentProject.Path & "\" & firstXML & ".xml" 

    Set xslDoc = New MSXML2.DOMDocument60 
    xslDoc.Load Application.CurrentProject.Path & "\MasterFile.xsl" 
    xslDoc.async = False 
    xslDoc.SetProperty "AllowDocumentFunction", True 

    ' TRANSFORM SOURCE TO NEW DOCUMENT 
    xmlDoc.transformNodeToObject xslDoc, newDoc 

    ' SAVE TRANSFORMED RESULT 
    newDoc.Save Application.CurrentProject.Path & "\MasterFile.xml" 

    Set xmlDoc = Nothing: Set xslDoc = Nothing: Set newDoc = Nothing 
    MsgBox "Succesfully built Master database XML!", vbDefaultButton1, "Export" 
    Exit Sub 

ErrHandle: 
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR" 
    Set xmlDoc = Nothing: Set xslDoc = Nothing: Set newDoc = Nothing 
    Exit Sub 
End Sub