把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