把Visio文档中形状信息导出到XML文件的VBA代码

从老外那里找来，做了一些修改，原文地址：http://www.vbaexpress.com/kb/getarticle.php?kb_id=506

Option Explicit
 
Public Sub LocationTable()
     'This routine will create a text file of the location and size of all 2-d shapes
     ' on the current page
    Dim shpObj     As Visio.Shape, celObj As Visio.Cell
    Dim ShpNo      As Integer, Tabchr     As String, localCent As Double
    Dim LocationX  As String, LocationY   As String
    Dim ShapeWidth As String, ShapeHeight As String
    Dim unit As String
    
    unit = "mm"
     'Open or create text file to write data
    Open "C:\temp\LocationTable.xml" For Output Shared As #1
     
    Tabchr = Chr(9) 'Tab
     
    Print #1, "<?xml version=""1.0"" encoding=""gb2312"" ?>"
    Print #1, "<document path="""; Visio.ActiveDocument.Path; """ name="""; Visio.ActiveDocument.Name; """>"
    Print #1, "<shapes unit="""; unit; """>"
     
     
     'Loop Shapes collection
    For ShpNo = 1 To Visio.ActivePage.Shapes.Count
         
        Set shpObj = Visio.ActivePage.Shapes(ShpNo)
        If Not shpObj.OneD Then ' Only list the 2-D shapes
             
             'Get location Shape
            Set celObj = shpObj.Cells("pinx")
            localCent = celObj.Result(unit)
            LocationX = localCent ' Format(localCent, "000.0000")
            Set celObj = shpObj.Cells("piny")
            localCent = celObj.Result(unit)
            LocationY = Format(localCent, "000.0000")
             
             'Get Size Shape
            Set celObj = shpObj.Cells("width")
            localCent = celObj.Result(unit)
            ShapeWidth = Format(localCent, "000.0000")
            Set celObj = shpObj.Cells("height")
            localCent = celObj.Result(unit)
            ShapeHeight = Format(localCent, "0.0000")
             
             'Write values to Text file starting Name of Shape
            Print #1, "<shape name="""; shpObj.Name; """ type="""; shpObj.Type; """ text="""; shpObj.Text; """ bounds="""; _
             LocationX; ","; LocationY; ","; ShapeWidth; ","; ShapeHeight; """ />"
        End If
         
    Next ShpNo
    
    Print #1, "</shapes>"
    Print #1, "</document>"
     'Close Textfile
    Close #1
     
     'Clean Up
    Set celObj = Nothing
    Set shpObj = Nothing
End Sub