从老外那里找来,做了一些修改,原文地址: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
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