generate table off content

[chapin]

Hi,

when dealing with many pages it's useful to generate a TOC.
Since there is apparently no standard function in visio,
i've done a workaround...
* Each page has a text shape named TOC (format-special)
* a VBA macro loops through the pages and generates the TOC from those TOC shapes


Here are my questions (coding see below):
* How to create a text shape instead of rectangles?
* How can I format the text (left aligned)?
* How can I create a goto-page doubleclick behaviour for the shapes instead of the hyperlinks?

Thanks for any hints
carsten


Here's my code:

Sub create_toc()
'***** from

http://www.mvps.org/visio/VBA.htm

'*** Creates a table of content on the first page of the drawing based
'*** on the text of shapes named TOC (right-click on shape, format-special-name)
'*** Adds a hyperlink to each shape so you can click and go to that page

'*** define a toc shape
Dim tocentry As Visio.Shape
Dim tocentry2 As Visio.Shape
Dim PageToIndex As Visio.Page
Dim X As Double
Dim hlink As Visio.Hyperlink
Dim i As Integer, j As Integer, ShpNo As Integer
Dim shpObj As Visio.Shape, celObj As Visio.Cell
Dim toc_entry_desc As String

'*** loop through all the pages of the drawing
For Each PageToIndex In Application.ActiveDocument.Pages

'*** loop to all shapes of the page. obtain text from shapes named "TOC"
'*** default text: "not found"
toc_entry_desc = "No shape with name TOC found on page " & PageToIndex & " !!!"
For ShpNo = 1 To PageToIndex.Shapes.Count
Set shpObj = PageToIndex.Shapes(ShpNo)
If shpObj.Name = "TOC" Then
toc_entry_desc = shpObj.Text
End If
Next ShpNo


'*** calculate position of TOC entry
X = 6 - PageToIndex.Index / 4

'** draw a rectangle for each page to hold the text
'** write the TOC text in the rectangle
Set tocentry = ActiveDocument.Pages(1).DrawRectangle(1, X, 4, X + 1 / 4)

'** draw 2nd rectangle aside with the according page name
Set tocentry2 = ActiveDocument.Pages(1).DrawRectangle(4, X, 5, X + 1 / 4)

'*** some stylings...
tocentry.Text = toc_entry_desc
tocentry.LineStyle = "None"
tocentry2.Text = PageToIndex.Name
tocentry2.LineStyle = "None"


'*** add hyperlink to point to the page to
'*** create a handle to add the hyperlink
Set hlink = tocentry.AddHyperlink
'*** link description
hlink.Description = toc_entry_name
'*** link address
hlink.SubAddress = PageToIndex.Name

Next
End Sub