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
