第17章 XML
17.1 为什么使用XML
代码清单17.1: 新式的驯鹿数据
代码
<?
xml version="1.0" encoding="UTF-8"
?>
< DataRoot >
< Reindeer >
< Name > Dasher </ Name >
< Disposition > Contemptuos </ Disposition >
< NoseColor > Black </ NoseColor >
</ Reindeer >
< Reindeer >
< Name > Donner </ Name >
< Disposition > Optimistic </ Disposition >
< NoseColor > Black </ NoseColor >
</ Reindeer >
< Reindeer >
< Name > Rudolph </ Name >
< Disposition > Cheerful </ Disposition >
< NoseColor > Bright Red </ NoseColor >
</ Reindeer >
</ DataRoot >
< DataRoot >
< Reindeer >
< Name > Dasher </ Name >
< Disposition > Contemptuos </ Disposition >
< NoseColor > Black </ NoseColor >
</ Reindeer >
< Reindeer >
< Name > Donner </ Name >
< Disposition > Optimistic </ Disposition >
< NoseColor > Black </ NoseColor >
</ Reindeer >
< Reindeer >
< Name > Rudolph </ Name >
< Disposition > Cheerful </ Disposition >
< NoseColor > Bright Red </ NoseColor >
</ Reindeer >
</ DataRoot >
代码清单17.2：老式的驯鹿数据
"
Dasher
"
"
Contemptuos
"
"
Black
"
" Donner " " Optimistic " " Black "
" Rudolph " " Cheerful " " Bright Red "
" Donner " " Optimistic " " Black "
" Rudolph " " Cheerful " " Bright Red "
代码清单17.3：扩展的驯鹿数据
代码
<?
xml version="1.0" encoding="UTF-8"
?>
< DataRoot >
< Reindeer >
< Name > Dasher </ Name >
< Disposition > Contemptuos </ Disposition >
< NoseColor > Black </ NoseColor >
< Childeren >
< Son > Mickey </ Son >
< Son > Mikey </ Son >
< Daughter > Mindy </ Daughter >
</ Childeren >
</ Reindeer >
< Reindeer >
< Name > Donner </ Name >
< Disposition > Optimistic </ Disposition >
< NoseColor > Black </ NoseColor >
< Childeren >
< Daughter > Dorothy </ Daughter >
</ Childeren >
</ Reindeer >
< Reindeer >
< Name > Rudolph </ Name >
< Disposition > Cheerful </ Disposition >
< NoseColor > Bright Red </ NoseColor >
</ Reindeer >
</ DataRoot >
< DataRoot >
< Reindeer >
< Name > Dasher </ Name >
< Disposition > Contemptuos </ Disposition >
< NoseColor > Black </ NoseColor >
< Childeren >
< Son > Mickey </ Son >
< Son > Mikey </ Son >
< Daughter > Mindy </ Daughter >
</ Childeren >
</ Reindeer >
< Reindeer >
< Name > Donner </ Name >
< Disposition > Optimistic </ Disposition >
< NoseColor > Black </ NoseColor >
< Childeren >
< Daughter > Dorothy </ Daughter >
</ Childeren >
</ Reindeer >
< Reindeer >
< Name > Rudolph </ Name >
< Disposition > Cheerful </ Disposition >
< NoseColor > Bright Red </ NoseColor >
</ Reindeer >
</ DataRoot >
17.2 XL中的XML
17.3 XML VBA风格
代码清单17.4：一个XML发货单
代码
<?
xml version="1.0" encoding="UTF-8"
?>
< Invoice >
< InvoiceNumber > 5050 </ InvoiceNumber >
< InvoiceDate > 10/31/03 </ InvoiceDate >
< Customer >
< CustomerName > Joe smith </ CustomerName >
< Address >
< Street > 111 Maple Ln </ Street >
< City > Apple Valley </ City >
< State > MN </ State >
< Zip > 55021 </ Zip >
< Phone > (612)555-5555 </ Phone >
</ Address >
</ Customer >
< Items >
< Item >
< Qty > 2 </ Qty >
< Description > XL Red Shirt </ Description >
< Price > 10.00 </ Price >
< ItemTotal > 20.00 </ ItemTotal >
</ Item >
< Item >
< Qty > 1 </ Qty >
< Description > Lg Blue Sweatshirt </ Description >
< Price > 24.00 </ Price >
< ItemTotal > 24.00 </ ItemTotal >
</ Item >
< Item >
< Qty > 1 </ Qty >
< Description > Boots </ Description >
< Price > 99.00 </ Price >
< ItemTotal > 99.00 </ ItemTotal >
</ Item >
</ Items >
</ Invoice >
< Invoice >
< InvoiceNumber > 5050 </ InvoiceNumber >
< InvoiceDate > 10/31/03 </ InvoiceDate >
< Customer >
< CustomerName > Joe smith </ CustomerName >
< Address >
< Street > 111 Maple Ln </ Street >
< City > Apple Valley </ City >
< State > MN </ State >
< Zip > 55021 </ Zip >
< Phone > (612)555-5555 </ Phone >
</ Address >
</ Customer >
< Items >
< Item >
< Qty > 2 </ Qty >
< Description > XL Red Shirt </ Description >
< Price > 10.00 </ Price >
< ItemTotal > 20.00 </ ItemTotal >
</ Item >
< Item >
< Qty > 1 </ Qty >
< Description > Lg Blue Sweatshirt </ Description >
< Price > 24.00 </ Price >
< ItemTotal > 24.00 </ ItemTotal >
</ Item >
< Item >
< Qty > 1 </ Qty >
< Description > Boots </ Description >
< Price > 99.00 </ Price >
< ItemTotal > 99.00 </ ItemTotal >
</ Item >
</ Items >
</ Invoice >
代码清单17.5: 向Workbook添加一个模式
代码
'
代码清单17.5: 向Workbook添加一个模式
Sub ImportXMLSchema()
Dim xmMap As XmlMap
' turn off display alerts - otherwise if you
' use an xml file rather than an xsd file,
' excel asks you about creating a schema
Application.DisplayAlerts = False
' add a map based on an xml file
' alternatively, an xsd file would work
Set xmMap = ActiveWorkbook.XmlMaps.Add( " D:\invoice.xml " , " Invoice " )
' Turn displayAlerts back on
Application.DisplayAlerts = True
' set any desired map properties
xmMap.AdjustColumnWidth = False
xmMap.PreserveNumberFormatting = True
Set xmMap = Nothing
End Sub
Sub ImportXMLSchema()
Dim xmMap As XmlMap
' turn off display alerts - otherwise if you
' use an xml file rather than an xsd file,
' excel asks you about creating a schema
Application.DisplayAlerts = False
' add a map based on an xml file
' alternatively, an xsd file would work
Set xmMap = ActiveWorkbook.XmlMaps.Add( " D:\invoice.xml " , " Invoice " )
' Turn displayAlerts back on
Application.DisplayAlerts = True
' set any desired map properties
xmMap.AdjustColumnWidth = False
xmMap.PreserveNumberFormatting = True
Set xmMap = Nothing
End Sub
代码清单17.6: 用范围来连接XML元素
代码
'
代码清单17.6: 用范围来连接XML元素
Sub MapRanges()
Dim xmMap As XmlMap
Dim ws As Worksheet
Dim sPath As String
Dim loList As ListObject
Set ws = ThisWorkbook.Worksheets( " Invoice " )
Set xmMap = ThisWorkbook.XmlMaps( " Invoice_Map " )
Application.DisplayAlerts = False
sPath = " /Invoice/Customer/CustomerName "
MapRange ws.Range( " CustomerName " ), xmMap, sPath
sPath = " /Invoice/Customer/Address/Street "
MapRange ws.Range( " Address " ), xmMap, sPath
sPath = " /Invoice/Customer/Address/City "
MapRange ws.Range( " City " ), xmMap, sPath
sPath = " /Invoice/Customer/Address/State "
MapRange ws.Range( " State " ), xmMap, sPath
sPath = " /Invoice/Customer/Address/Zip "
MapRange ws.Range( " Zip " ), xmMap, sPath
sPath = " /Invoice/Customer/Address/Phone "
MapRange ws.Range( " Phone " ), xmMap, sPath
sPath = " /Invoice/InvoiceNumber "
MapRange ws.Range( " Number " ), xmMap, sPath
sPath = " /Invoice/InvoiceDate "
MapRange ws.Range( " Date " ), xmMap, sPath
Set loList = ws.ListObjects.Add(xlSrcRange, ws.Range( " Qty " ).Resize( 2 , 4 ), , xlYes)
sPath = " /Invoice/Items/Item/Qty "
MapRepeatingRange loList.ListColumns( 1 ), xmMap, sPath
sPath = " /Invoice/Items/Item/Description "
MapRepeatingRange loList.ListColumns( 2 ), xmMap, sPath
sPath = " /Invoice/Items/Item/Price "
MapRepeatingRange loList.ListColumns( 3 ), xmMap, sPath
sPath = " /Invoice/Items/Item/ItemTotal "
MapRepeatingRange loList.ListColumns( 4 ), xmMap, sPath
Application.DisplayAlerts = True
Set xmMap = Nothing
Set ws = Nothing
Set loList = Nothing
End Sub
Function MapRange(rg As Range, xmMap As XmlMap, sPath As String ) As Boolean
On Error GoTo ErrHandler
' If the range isn't already mapped
' it's ok to use SetValue...
If rg.XPath.Value = "" Then
rg.XPath.SetValue xmMap, sPath
Else
' otherwise you need to clear
' the existing mapped item
rg.XPath.Clear
' before using setValue
rg.XPath.SetValue xmMap, sPath
End If
MapRange = True
Exit Function
ErrHandler:
MapRange = True
End Function
Function MapRepeatingRange(lcColumn As ListColumn, xmMap As XmlMap, sPath As String ) As Boolean
On Error GoTo ErrHandler
' Map a ListObject column to an XLM element
lcColumn.XPath.SetValue xmMap, sPath
Exit Function
MapRepeatingRange = True
ErrHandler:
Debug.Print Err.Description
MapRepeatingRange = False
End Function
Sub MapRanges()
Dim xmMap As XmlMap
Dim ws As Worksheet
Dim sPath As String
Dim loList As ListObject
Set ws = ThisWorkbook.Worksheets( " Invoice " )
Set xmMap = ThisWorkbook.XmlMaps( " Invoice_Map " )
Application.DisplayAlerts = False
sPath = " /Invoice/Customer/CustomerName "
MapRange ws.Range( " CustomerName " ), xmMap, sPath
sPath = " /Invoice/Customer/Address/Street "
MapRange ws.Range( " Address " ), xmMap, sPath
sPath = " /Invoice/Customer/Address/City "
MapRange ws.Range( " City " ), xmMap, sPath
sPath = " /Invoice/Customer/Address/State "
MapRange ws.Range( " State " ), xmMap, sPath
sPath = " /Invoice/Customer/Address/Zip "
MapRange ws.Range( " Zip " ), xmMap, sPath
sPath = " /Invoice/Customer/Address/Phone "
MapRange ws.Range( " Phone " ), xmMap, sPath
sPath = " /Invoice/InvoiceNumber "
MapRange ws.Range( " Number " ), xmMap, sPath
sPath = " /Invoice/InvoiceDate "
MapRange ws.Range( " Date " ), xmMap, sPath
Set loList = ws.ListObjects.Add(xlSrcRange, ws.Range( " Qty " ).Resize( 2 , 4 ), , xlYes)
sPath = " /Invoice/Items/Item/Qty "
MapRepeatingRange loList.ListColumns( 1 ), xmMap, sPath
sPath = " /Invoice/Items/Item/Description "
MapRepeatingRange loList.ListColumns( 2 ), xmMap, sPath
sPath = " /Invoice/Items/Item/Price "
MapRepeatingRange loList.ListColumns( 3 ), xmMap, sPath
sPath = " /Invoice/Items/Item/ItemTotal "
MapRepeatingRange loList.ListColumns( 4 ), xmMap, sPath
Application.DisplayAlerts = True
Set xmMap = Nothing
Set ws = Nothing
Set loList = Nothing
End Sub
Function MapRange(rg As Range, xmMap As XmlMap, sPath As String ) As Boolean
On Error GoTo ErrHandler
' If the range isn't already mapped
' it's ok to use SetValue...
If rg.XPath.Value = "" Then
rg.XPath.SetValue xmMap, sPath
Else
' otherwise you need to clear
' the existing mapped item
rg.XPath.Clear
' before using setValue
rg.XPath.SetValue xmMap, sPath
End If
MapRange = True
Exit Function
ErrHandler:
MapRange = True
End Function
Function MapRepeatingRange(lcColumn As ListColumn, xmMap As XmlMap, sPath As String ) As Boolean
On Error GoTo ErrHandler
' Map a ListObject column to an XLM element
lcColumn.XPath.SetValue xmMap, sPath
Exit Function
MapRepeatingRange = True
ErrHandler:
Debug.Print Err.Description
MapRepeatingRange = False
End Function
代码清单17.7: 导入一个XML数据文件
代码
'
代码清单17.7: 导入一个XML数据文件
Sub ImportXMLData()
Dim xlImportResult As XlXmlImportResult
xlImportResult = ThisWorkbook.XmlMaps( " Invoice_Map " ).Import( " C:\invoice.xml " , True )
Select Case xlImportResult
Case xlXmlImportElementsTruncated
Debug.Print " xml data items imported with truncation. "
Case xlXmlImportSuccess
Debug.Print " xml data items imported successfully. "
Case xlXmlImportValidationFailed
Debug.Print " xml data items not imported. Validation failed. "
Case Else
Debug.Print " data import process reported an unknown result code. "
End Select
Set xlImportResult = Nothing
End Sub
Sub ImportXMLData()
Dim xlImportResult As XlXmlImportResult
xlImportResult = ThisWorkbook.XmlMaps( " Invoice_Map " ).Import( " C:\invoice.xml " , True )
Select Case xlImportResult
Case xlXmlImportElementsTruncated
Debug.Print " xml data items imported with truncation. "
Case xlXmlImportSuccess
Debug.Print " xml data items imported successfully. "
Case xlXmlImportValidationFailed
Debug.Print " xml data items not imported. Validation failed. "
Case Else
Debug.Print " data import process reported an unknown result code. "
End Select
Set xlImportResult = Nothing
End Sub
代码清单17.8: 导出xml
代码
'
代码清单17.8: 导出xml
Sub ExportInvoiceXml()
Dim xlMap As XmlMap
Set xlMap = ThisWorkbook.XmlMaps( " Invoice_Map " )
If xlMap.IsExportable Then
xlMap.Export " c:\testxmljunk.xml "
Else
MsgBox " Sorry, this xml map is not exportable " , vbOKOnly
End If
Set xlMap = Nothing
End Sub
Sub ExportInvoiceXml()
Dim xlMap As XmlMap
Set xlMap = ThisWorkbook.XmlMaps( " Invoice_Map " )
If xlMap.IsExportable Then
xlMap.Export " c:\testxmljunk.xml "
Else
MsgBox " Sorry, this xml map is not exportable " , vbOKOnly
End If
Set xlMap = Nothing
End Sub
17.4 List对象初探
代码清单17.9:检查ListObject
代码
'
代码清单17.9:检查ListObject
' Example using various list properties
Sub ListInfo()
Dim ws As Worksheet
Dim lo As ListObject
Dim lc As ListColumn
Dim rg As Range
Set ws = ThisWorkbook.Worksheets( " ListObjects " )
Set lo = ws.ListObjects( 1 )
' Display column info
Set rg = ws.Cells( 17 , 2 )
For Each lc In lo.ListColumns
rg.Value = lc.Name
rg.Offset( 1 , 0 ).Value = lc.Index
rg.Offset( 2 , 0 ).Value = lc.Range.Address
rg.Offset( 4 , 0 ).Value = GetTotalsCalculation(lc.TotalsCalculation)
Set rg = rg.Offset( 0 , 1 )
Next
' display general list info
Set rg = ws.Cells( 25 , 2 )
rg.Value = lo.InsertRowRange.Address
rg.Offset( 1 , 0 ).Value = lo.DataBodyRange.Address
' If the InsertRowRange is not currently displayed
' then InsertRowRange is nothing
If Not lo.InsertRowRange Is Nothing Then
rg.Offset( 2 , 0 ).Value = lo.InsertRowRange.Address
Else
rg.Offset( 2 , 0 ).Value = " N/A "
End If
' if the TotalsRowRange is not being displayed
' then TotalsRowRange is nothing
If lo.ShowTotals Then
rg.Offset( 3 , 0 ).Value = lo.TotalsRowRange.Address
Else
rg.Offset( 3 , 0 ).Value = " N/A "
End If
' Get some more information from the list object
rg.Offset( 4 , 0 ).Value = lo.Range.Address
rg.Offset( 5 , 0 ).Value = lo.ShowTotals
rg.Offset( 6 , 0 ).Value = lo.ShowAutoFilter
Set rg = Nothing
Set lc = Nothing
Set lo = Nothing
Set ws = Nothing
End Sub
' Converts an xlTotalsCalculation enumeration value to a string
Function GetTotalsCalculation(xlCalc As XlTotalsCalculation) As String
Select Case xlCalc
Case XlTotalsCalculation.xlTotalsCalculationAverage
GetTotalsCalculation = " Average "
Case XlTotalsCalculation.xlTotalsCalculationCount
GetTotalsCalculation = " Count "
Case XlTotalsCalculation.xlTotalsCalculationCountNums
GetTotalsCalculation = " CountNums "
Case XlTotalsCalculation.xlTotalsCalculationMax
GetTotalsCalculation = " Max "
Case XlTotalsCalculation.xlTotalsCalculationMin
GetTotalsCalculation = " Min "
Case XlTotalsCalculation.xlTotalsCalculationNone
GetTotalsCalculation = " None "
Case XlTotalsCalculation.xlTotalsCalculationStdDev
GetTotalsCalculation = " StdDev "
Case XlTotalsCalculation.xlTotalsCalculationSum
GetTotalsCalculation = " Sum "
Case XlTotalsCalculation.xlTotalsCalculationVar
GetTotalsCalculation = " Var "
Case Else
GetTotalsCalculation = " Unkown "
End Select
End Function
' Example using various list properties
Sub ListInfo()
Dim ws As Worksheet
Dim lo As ListObject
Dim lc As ListColumn
Dim rg As Range
Set ws = ThisWorkbook.Worksheets( " ListObjects " )
Set lo = ws.ListObjects( 1 )
' Display column info
Set rg = ws.Cells( 17 , 2 )
For Each lc In lo.ListColumns
rg.Value = lc.Name
rg.Offset( 1 , 0 ).Value = lc.Index
rg.Offset( 2 , 0 ).Value = lc.Range.Address
rg.Offset( 4 , 0 ).Value = GetTotalsCalculation(lc.TotalsCalculation)
Set rg = rg.Offset( 0 , 1 )
Next
' display general list info
Set rg = ws.Cells( 25 , 2 )
rg.Value = lo.InsertRowRange.Address
rg.Offset( 1 , 0 ).Value = lo.DataBodyRange.Address
' If the InsertRowRange is not currently displayed
' then InsertRowRange is nothing
If Not lo.InsertRowRange Is Nothing Then
rg.Offset( 2 , 0 ).Value = lo.InsertRowRange.Address
Else
rg.Offset( 2 , 0 ).Value = " N/A "
End If
' if the TotalsRowRange is not being displayed
' then TotalsRowRange is nothing
If lo.ShowTotals Then
rg.Offset( 3 , 0 ).Value = lo.TotalsRowRange.Address
Else
rg.Offset( 3 , 0 ).Value = " N/A "
End If
' Get some more information from the list object
rg.Offset( 4 , 0 ).Value = lo.Range.Address
rg.Offset( 5 , 0 ).Value = lo.ShowTotals
rg.Offset( 6 , 0 ).Value = lo.ShowAutoFilter
Set rg = Nothing
Set lc = Nothing
Set lo = Nothing
Set ws = Nothing
End Sub
' Converts an xlTotalsCalculation enumeration value to a string
Function GetTotalsCalculation(xlCalc As XlTotalsCalculation) As String
Select Case xlCalc
Case XlTotalsCalculation.xlTotalsCalculationAverage
GetTotalsCalculation = " Average "
Case XlTotalsCalculation.xlTotalsCalculationCount
GetTotalsCalculation = " Count "
Case XlTotalsCalculation.xlTotalsCalculationCountNums
GetTotalsCalculation = " CountNums "
Case XlTotalsCalculation.xlTotalsCalculationMax
GetTotalsCalculation = " Max "
Case XlTotalsCalculation.xlTotalsCalculationMin
GetTotalsCalculation = " Min "
Case XlTotalsCalculation.xlTotalsCalculationNone
GetTotalsCalculation = " None "
Case XlTotalsCalculation.xlTotalsCalculationStdDev
GetTotalsCalculation = " StdDev "
Case XlTotalsCalculation.xlTotalsCalculationSum
GetTotalsCalculation = " Sum "
Case XlTotalsCalculation.xlTotalsCalculationVar
GetTotalsCalculation = " Var "
Case Else
GetTotalsCalculation = " Unkown "
End Select
End Function