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

如何使用此代码的格式，但将多个表导出到一个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>

表格的外观如下：

table

Answer 1

考虑使用TableDefs集合循环遍历所有数据库表，迭代地使用传入参数调用ExportXML()函数。同时构建一个特殊的XSLT脚本，以便稍后将所有生成的XML文件绑定到一个主文件中。

作为信息，XSLT是一种专用语言，旨在转换XML文件，并可以使用其document()函数导入外部XML。 XSLT必须保存到磁盘而不在内存中使用，因为它必须读取其他XML文件的目录。

XSLT 型号

（在下面的代码中动态构建的脚本;首先注意Table1.xml未声明，因为它是VBA中的原始转换源）

<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 （使用包含表名参数的原始函数）

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

将多个表从Access导出到一个XML文件

1 个答案: