From the foreigners to find, made some changes, the original address: 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
