Hello fellow Viso users,
since I am new to your form I shall introduce myself briefly. My Name is Tim and I am from Germany. My english is quite well unfortunately my programming skills aren't.
I am currently working on a business process portal for my company which should included all the major processes at some point. For each departmend I have created one visio file which has every process as a seperate page. After the portal is finished it will be published on the intranet of my company which is based on sharepoint.
To make navigation easy I had the idea of putting a small table of content on every page that tells the user where in he visio file he or she currently is. So there should be a highlight or something in the table indicating the active page.
I found a macro which does the table but I was not able to customize it the way I need it to be.
Maybe you can help me with that.
Sub TableOfContents()
' creates a shape for each page in the drawing on the first page of the drawing
' then add a dbl-clk GoTo to each shape so you can double click and go to that Page
Dim PageObj As Visio.Page
Dim TOCEntry As Visio.Shape
Dim CellOjb As Visio.Cell
Dim PosY As Double
Dim PageCnt As Double
' ActiveDocument.Pages.Count will give the number of pages, but we are interested
' the number of foreground pages
PageCnt = 0
For Each PageObj In ActiveDocument.Pages
If PageObj.Background = False Then PageCnt = PageCnt + 1
Next
' loop through all the pages
For Each PageObj In ActiveDocument.Pages
If PageObj.Background = False Then ' Only foreground pages
' where to put the entry on the page?
PosY = (PageCnt - PageObj.Index) / 4 + 1
' draw a rectangle for each page to hold the text
Set TOCEntry = ActiveDocument.Pages(1).DrawRectangle(1, PosY, 4, PosY + 0.25)
' write the page name in the rectangle
TOCEntry.Text = PageObj.Name
' add a link to point to the page to you can just go there with a Double Click
Set CellObj = TOCEntry.CellsSRC(visSectionObject, visRowEvent, visEvtCellDblClick) 'Start
CellObj.Formula = "GOTOPAGE(""" + PageObj.Name + """)"
End If
Next
End Sub
Guten Tag!
Attached is what I came up with, in both the new 2003-2010 format (.vsd) as well as the 2013 and newer format (.vsdm).
The files contain 3 blank pages. Once you run the TableOfContents macro found in Module1, your desired Table of Contents will be added to each page.
A couple of other minor details I included that you may find useful:
- if the user hovers the mouse over a TOC entry shape, some text will appear to let the user know they can double-click to go to that page.
- added a section of code that can set some of the ShapeSheet values to prevent users from accidentally modifying your Table of Contents shapes. As I pointed out in the comments of my code, you just need to un-comment whatever lines you think you might want to use.
As I understand it, VBA does it's best and fastest work in loops (especially in Excel).
My example uses 3 loops, with the last one being nested inside the 2nd:
- one loop to examine the pages in the document and gather a list (in this case a Collection (https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/collection-object)) of only the pages that are foreground
- one loop to go through each foreground page we found and start drawing a Table of Contents
- last loop nested in the one above to once again go through each foreground page found to draw an entry in the Table of Contents
Option Explicit
Sub TableOfContents()
'''''''''*'''''''''*'''''''''*'''''''''*'''''''''*'''''''''*'''''''''*'''''''''*
' creates a Table of Contents on every foreground page of a document.
' each TOC has a rectangle shape for each page in the document.
' current page is highlighted in the TOC, and users can double-click a TOC entry
' to go to that page.
'''''''''*'''''''''*'''''''''*'''''''''*'''''''''*'''''''''*'''''''''*'''''''''*
Dim fgndPages As Collection
Dim PageObj As Visio.Page
Dim TOCPage As Visio.Page
Dim TOCEntry As Visio.Shape
Dim PosY As Double
'find only the foreground pages and add them to a collection
Set fgndPages = New Collection
For Each PageObj In ActiveDocument.Pages
If PageObj.Background = False Then fgndPages.Add PageObj, PageObj.Name
Next
'draw a TOC on each foreground page found
For Each PageObj In fgndPages
'on the current foreground page, draw a TOC entry for each foreground page
For Each TOCPage In fgndPages
'where to put the entry on the page?
PosY = (fgndPages.Count - TOCPage.Index) / 4 + 1
'draw a rectangle for each page to hold the text
Set TOCEntry = PageObj.DrawRectangle(1, PosY, 4, PosY + 0.25)
'write the page name in the rectangle
TOCEntry.Text = TOCPage.Name
'set some ShapeSheet values so users do not accidentally change any
'TOC entry shapes.
'un-comment any of these lines as you see fit ONLY WHEN you are
'ready to test your final solution (as you might expect, these lines
'make it a pain to delete the TOC entry shapes).
' TOCEntry.CellsU("NoObjHandles").FormulaU = "=GUARD(true)"
' TOCEntry.CellsU("NoAlignBox").FormulaU = "=GUARD(true)"
' TOCEntry.CellsU("LockWidth").FormulaU = "=GUARD(1)"
' TOCEntry.CellsU("LockHeight").FormulaU = "=GUARD(1)"
' TOCEntry.CellsU("LockMoveX").FormulaU = "=GUARD(1)"
' TOCEntry.CellsU("LockMoveY").FormulaU = "=GUARD(1)"
' TOCEntry.CellsU("LockRotate").FormulaU = "=GUARD(1)"
' TOCEntry.CellsU("LockDelete").FormulaU = "=GUARD(1)"
'if the current TOC entry is the same as the current page where we are
'drawing the TOC, then change the fill color of the TOC entry shape.
'otherwise, add a link to the page of the current TOC entry.
If TOCPage.Name = PageObj.Name Then
'change the RGB #s to whatever color you want to use as highlight
TOCEntry.CellsU("FillForegnd").FormulaU = "=GUARD(RGB(255,255,0))"
TOCEntry.CellsU("FillPattern").FormulaU = "=GUARD(1)"
TOCEntry.CellsU("EventDblClick").FormulaU = "=GUARD(0)"
TOCEntry.CellsU("Comment").FormulaU = """This is the current page."""
Else
TOCEntry.CellsU("EventDblClick").FormulaU = "GOTOPAGE(""" + TOCPage.Name + """)"
TOCEntry.CellsU("Comment").FormulaU = """Double click to go to this page."""
End If
Next TOCPage
Next PageObj
'memory management stuff
'not sure if this is 100% necessary but i hear it is good practice
Set fgndPages = Nothing
Set PageObj = Nothing
Set TOCPage = Nothing
Set TOCEntry = Nothing
End Sub
MSDN References for the ShapeSheet cells that are changed by my code:
- NoObjHandles Cell (Miscellaneous Section) (https://msdn.microsoft.com/en-us/library/office/ff767367.aspx)
- NoAlignBox Cell (Miscellaneous Section) (https://msdn.microsoft.com/en-us/library/office/ff767929.aspx)
- LockWidth Cell (Protection Section) (https://msdn.microsoft.com/en-us/library/office/ff769182.aspx)
- LockHeight Cell (Protection Section) (https://msdn.microsoft.com/en-us/library/office/ff765578.aspx)
- LockMoveX Cell (Protection Section) (https://msdn.microsoft.com/en-us/library/office/ff766217.aspx)
- LockMoveY Cell (Protection Section) (https://msdn.microsoft.com/en-us/library/office/ff766297.aspx)
- LockRotate Cell (Protection Section) (https://msdn.microsoft.com/en-us/library/office/ff765766.aspx)
- LockDelete Cell (Protection Section) (https://msdn.microsoft.com/en-us/library/office/ff766456.aspx)
- FillForegnd Cell (Fill Format Section) (https://msdn.microsoft.com/en-us/library/office/ff766955.aspx)
- FillPattern Cell (Fill Format Section) (https://msdn.microsoft.com/en-us/library/office/ff768553.aspx)
- EventDblClick Cell (Events Section) (https://msdn.microsoft.com/en-us/library/office/ff768304.aspx)
- Comment Cell (Miscellaneous Section) (https://msdn.microsoft.com/en-us/library/office/ff766872.aspx)
Viel glück!
Guten Morgen,
exactly what I've been looking for!
Thank you so much/ Vielen Dank.