Table of Contents macro and instructions

[xgrove]

I'm rolling off of my current engagement and would like to donate a copy of the Table of Contents that I created for the project's many Visio process maps.

Thank you wapperdude for your assistance.

RG

[SubPlanner]

Delete Un-needed TOC shapes.

Is there a string of VBA code that could be added to this code that would delete all the shapes off of the TOC page prior to adding a refreshed list of page names on the first tab named "TOC".

I have been using this code and would like to run it every time the project gets refreshed. I have been removing pages but the old page name remains behind even though it had been deleted.

Thanks for any assistance.

SubPlanner.

[xgrove]

Subplanner - Your suggestion is a good one. I was unable to figure out how to do that because the items written to the TOC page don't appear to be addressable (i.e. not objects). Good luck with your quest.

[SubPlanner]

I figured it out. I am using this code.
My sheet is named TOC. It is the first sheet.

Public Sub Del_TOC()
    Dim DiagramServices As Integer
   
    DiagramServices = ActiveDocument.DiagramServicesEnabled
    ActiveDocument.DiagramServicesEnabled = visServiceVersion140

    'Application.ActiveWindow.SelectAll
    ActiveWindow.Page = ActiveDocument.Pages("TOC")
   
    ActiveWindow.SelectAll
    Application.ActiveWindow.Selection.DeleteEx (visDeleteNormal)

    'Restore diagram services
    ActiveDocument.DiagramServicesEnabled = DiagramServices
End Sub

SubPlanner

[Yacine]

@xgrove,
Thanks for sharing. It's always nice when people give back a little bit from what the get in the forum.
@ xgrove and subPlanner,
Deleting everything on the TOC page can be a solution, but not if you have other "decorations" on it.
Better would be to mark the TOCEntries as such, then delete only them.
I had a little time to exercise and thought, I'd share as well:

Code

Option Explicit
 
Sub TableOfContents()
   
    ' -----------------------------------------------------------------
    ' Creates stacked page references on first page of the drawing
    ' Double-click the "button" label to go to that page
    '
    ' REMEMBER: Set the theme to NO THEME (first option) on Design Menu
    ' -----------------------------------------------------------------

    Dim PageObj   As Visio.Page     ' sheet
    Dim TOCEntry  As Visio.Shape    ' shape containing sheet name
    Dim CellObj   As Visio.Cell     ' jump point
    Dim PosY      As Double         ' starting point on the vertical axis
    Dim pageCount As Double         ' number of pages
    Dim loopCount As Integer        ' times going through For Each statement
    Dim shp As Shape
    Dim userRow As Integer
         
    ' ActiveDocument.Pages.Count will give the number of pages
    ' Notice: We're only interested in the number of foreground pages
    
    For Each PageObj In ActiveDocument.Pages    ' count the number of sheets
        If PageObj.Background = False Then pageCount = pageCount + 1
    Next
    
    ' Delete existing Entries
    ActiveWindow.Page = ActiveDocument.Pages(1)
    For Each shp In ActivePage.Shapes
        If shp.CellExistsU("User.type", False) Then
            If shp.Cells("user.type").ResultStr("") = "TOCEntry" Then
                shp.Delete
            End If
        End If
    Next shp
    
    ' Set variables
    loopCount = 0
 
    For Each PageObj In ActiveDocument.Pages
        
        If loopCount > 0 Then ' skip the [Table of Contents] page
        
          If PageObj.Background = False Then ' Only foreground pages
             
            ' PosY = startPoint - (pass x (height + gap)) <-- Chose the vertical starting point on the page
            PosY = 7.75 - (PageObj.Index * 0.4)
            Set TOCEntry = ActiveDocument.Pages(1).DrawRectangle(4.6, PosY, 4, PosY + 0.5)
            
            ' Write the page name in the rectangle
            TOCEntry.Text = PageObj.Name
            TOCEntry.Cells("VerticalAlign").Formula = "1" 'middle align
            TOCEntry.Cells("Para.HorzAlign").Formula = visHorzLeft 'make text box left aligned
            TOCEntry.Cells("Width").Formula = "6 in"
            TOCEntry.Cells("Height").Formula = "0.36 in"
            TOCEntry.Cells("Char.Size").Formula = "16 pt."
            
            ' Make the TOC Entry "recognizable"
            userRow = TOCEntry.AddRow(visSectionUser, visRowLast, visTagDefault)
            TOCEntry.Section(visSectionUser).Row(userRow).NameU = "Type"
            TOCEntry.Cells("user.Type").FormulaU = Chr(34) & "TOCEntry" & Chr(34)
            
            ' Alternate the foreground color
            If (loopCount Mod 2 = 0) Then
                TOCEntry.Cells("FillForegnd").FormulaU = "RGB(195, 215, 232)"
            Else
                TOCEntry.Cells("FillForegnd").FormulaU = "RGB(224, 230, 205)"
            End If
                                   
            ' Add a link to the sheets
            Set CellObj = TOCEntry.CellsSRC(visSectionObject, visRowEvent, visEvtCellDblClick)
            CellObj.Formula = "GOTOPAGE(""" + PageObj.Name + """)"
           End If
           
        End If
        loopCount = loopCount + 1   ' increment the loop counter
        
    Next
     
    ' Clean Up Environment
    Set CellObj = Nothing
    Set TOCEntry = Nothing
    Set PageObj = Nothing
End Sub

[SubPlanner]

@Yacine.....

I do like the ability to keep other items on the page.
But, when you run this code over and over, you will get multiple boxes on top of one another.
I guess that's why I did a full delete.
Let me know if you come up with a way to keep just one record of each page on the TOC page.

SubPlanner

[Yacine]

  Please look again at the code.

[SubPlanner]

Yacine, I did  not look to well at that, sorry.

I am attaching my latest variation on the TOC code.

SubPlanner.

Code

Sub TblOfCont()
   
    ' -----------------------------------------------------------------
    ' Creates stacked page references on a page named TOC in your drawing
    ' Double-click the "button" label to go to that page
    '
    ' REMEMBER: Set the theme to NO THEME (first option) on Design Menu
    ' -----------------------------------------------------------------
        '1/6/2016 Modified code by SubPlanner. Originated by Visio Guy.
        'This variation of code allows me to create a TOC (Table of Contents) at any time.
        'With Yacines add ons, pages that you delete will be removed from the TOC while leaving decorations alone
        'The TOC page was set to background so that it will not show up when the file is saved as a .PDF
        'Also the code looks for the page named TOC instead of just looking for the first page in your report.
        'I run this code from a button on a page named Update. see the last line of code before "Clean Up Environment".
            'You may need to tick this out or change it to what you have in your drawing.

    Dim PageObj   As Visio.Page     ' sheet
    Dim TOCEntry  As Visio.Shape    ' shape containing sheet name
    Dim CellObj   As Visio.Cell     ' jump point
    Dim PosY      As Double         ' starting point on the vertical axis
    Dim pageCount As Double         ' number of pages
    Dim loopCount As Integer        ' times going through For Each statement
    Dim shp As Shape
    Dim userRow As Integer
         
    ' ActiveDocument.Pages.Count will give the number of pages
    ' Notice: We're only interested in the number of foreground pages
    
    For Each PageObj In ActiveDocument.Pages    ' count the number of sheets
    If PageObj.Background = False Then pageCount = pageCount + 1
    Next
    
    ActiveWindow.Page = ActiveDocument.Pages("TOC")     'ActiveDocument.Pages(1)
    For Each shp In ActivePage.Shapes
        If shp.CellExistsU("User.type", False) Then
            If shp.Cells("user.type").ResultStr("") = "TOCEntry" Then
                shp.Delete
            End If
        End If
    Next shp
         
    ' Set variables
    loopCount = 1
 
    For Each PageObj In ActiveDocument.Pages
        
        If loopCount > 0 Then
        
          If PageObj.Background = False Then ' Only foreground pages
             
            ' PosY = startPoint - (pass x (height + gap)) <-- Chose the vertical starting point on the page
            PosY = 7.75 - (PageObj.Index * 0.25)
            ''''Set TOCEntry = ActiveDocument.Pages(1).DrawRectangle(4.6, PosY, 4, PosY + 0.5)'this put it on the first page of your file...yuk
            Set TOCEntry = ActiveDocument.Pages("TOC").DrawRectangle(4.1, PosY, 3, PosY + 0.5) 'this put it on the page I want
            
            ' Write the page name in the rectangle.  'SubPlanner tightend the dimensions up a little here
            TOCEntry.Text = PageObj.Name
            TOCEntry.Cells("VerticalAlign").Formula = "1" 'middle align
            TOCEntry.Cells("Para.HorzAlign").Formula = visHorzLeft 'make text box left aligned
            TOCEntry.Cells("Width").Formula = "3 in"
            TOCEntry.Cells("Height").Formula = "0.26 in"
            TOCEntry.Cells("Char.Size").Formula = "12 pt."
            
            userRow = TOCEntry.AddRow(visSectionUser, visRowLast, visTagDefault)
            TOCEntry.Section(visSectionUser).Row(userRow).NameU = "Type"
            TOCEntry.Cells("user.Type").FormulaU = Chr(34) & "TOCEntry" & Chr(34)
                       
            ' Alternate the foreground color
            If (loopCount Mod 2 = 0) Then
                TOCEntry.Cells("FillForegnd").FormulaU = "RGB(195, 215, 232)"
            Else
                TOCEntry.Cells("FillForegnd").FormulaU = "RGB(224, 230, 205)"
            End If
                                   
            ' Add a link to the sheets
            Set CellObj = TOCEntry.CellsSRC(visSectionObject, visRowEvent, visEvtCellDblClick)
            CellObj.Formula = "GOTOPAGE(""" + PageObj.Name + """)"
           End If
           
        End If
        loopCount = loopCount + 1   ' increment the loop counter
        
    Next
    
    ActiveWindow.Page = ActiveDocument.Pages.ItemU("Update") 'Returns to Update Page.
     
    ' Clean Up Environment
    Set CellObj = Nothing
    Set TOCEntry = Nothing
    Set PageObj = Nothing
End Sub