Option Explicit
Sub TableOfContents()
Dim PageObj As Visio.Page
Dim TOCEntry As Visio.Shape
Dim CellObj As Visio.Cell
Dim PosY As Double
Dim PageCnt As Double
PageCnt = 0
For Each PageObj In ActiveDocument.Pages
If PageObj.Background = False Then PageCnt = PageCnt + 1
Next
For Each PageObj In ActiveDocument.Pages
If PageObj.Background = False Then
PosY = (PageCnt - PageObj.Index) / 4 + 1
Set TOCEntry = ActiveDocument.Pages(1).DrawRectangle(1, PosY, 4, PosY + 0.25)
TOCEntry.Text = PageObj.Name
Set CellObj = TOCEntry.CellsSRC(visSectionObject, visRowEvent, visEvtCellDblClick)
CellObj.Formula = "GOTOPAGE(""" + PageObj.Name + """)"
End If
Next
Set CellObj = Nothing
Set TOCEntry = Nothing
Set PageObj = Nothing
End Sub
|