Visio Macro on New Page

[l2l]

This macro changes the date when printed only on Page1 of a Visio Flowchart. Is there a way to work with all pages?

Thanks,
L2L

Private Sub AddMenuItem()

Dim visMenuSetsObj As Visio.MenuSets
Dim visMenuSetObj As Visio.MenuSet
Dim visMenusObj As Visio.Menus
Dim visMenuObj As Visio.Menu
Dim visMenuItemObj As Visio.MenuItem
Dim iItemCount As Integer
Dim visMenuItemSep As Visio.MenuItem
Dim iMnuItems As Integer
Dim varMenuItemCaption As Variant
Dim varWizardName As Variant
Dim strPath As String
Dim visUIobj As Visio.UIObject
Dim iMenucount As Integer
Dim bNoTools As Boolean
Dim iAddonCount As Integer
Dim bDatabase As Boolean
Dim bFlowTQM As Boolean
Dim bColorSchemes As Boolean
Dim szarrAddonNames() As String

'LocalizeBegin
Const ADDON_DATABASE = "&Flowchart Database Wizard"
Const ADDON_FLOWTQM = "Flowchart-T&QM Diagram Wizard"
Const ADDON_COLORSCHEMES = "Color Schemes..."

Const FILE_DATABASE = "Flowchart Database Wizard.exe"
Const FILE_FLOWTQM = "Flowchart-TQM Diagram Wizard.exe"
Const FILE_COLORSCHEMES = "Color Schemes"

Const CUST_UI_FILENAME = "custUI.vsu"

Const MENU_TOOLS = "&Tools"

Const RUN = "Run "
'LocalizeEnd

On Error GoTo EXIT_ON_ERROR


'Check each wizard first to see whether it can be found on the computer
bDatabase = False
bFlowTQM = False
bColorSchemes = False

Visio.Application.Addons.GetNames szarrAddonNames
For iAddonCount = 0 To UBound(szarrAddonNames)

If szarrAddonNames(iAddonCount) = UCase(FILE_DATABASE) Then bDatabase = True
If szarrAddonNames(iAddonCount) = UCase(FILE_FLOWTQM) Then bFlowTQM = True
If szarrAddonNames(iAddonCount) = FILE_COLORSCHEMES Then bColorSchemes = True

Next 'iAddonCount

'Populate the arrays
If bDatabase And bFlowTQM And bColorSchemes Then
iMnuItems = 3 'Number of menu items to be added
varMenuItemCaption = Array(ADDON_COLORSCHEMES, ADDON_DATABASE, ADDON_FLOWTQM)
varWizardName = Array(FILE_COLORSCHEMES, FILE_DATABASE, FILE_FLOWTQM)
varWizardArgs = Array("", "", "")

ElseIf bDatabase And Not (bFlowTQM) And bColorSchemes Then
iMnuItems = 2 'Number of menu items to be added
varMenuItemCaption = Array(ADDON_COLORSCHEMES, ADDON_DATABASE)
varWizardName = Array(FILE_COLORSCHEMES, FILE_DATABASE)
varWizardArgs = Array("", "")

ElseIf bFlowTQM And Not (bDatabase) And bColorSchemes Then
iMnuItems = 2 'Number of menu items to be added
varMenuItemCaption = Array(ADDON_COLORSCHEMES, ADDON_FLOWTQM)
varWizardName = Array(FILE_COLORSCHEMES, FILE_FLOWTQM)
varWizardArgs = Array("", "")

ElseIf bDatabase And bFlowTQM And Not (bColorSchemes) Then
iMnuItems = 2 'Number of menu items to be added
varMenuItemCaption = Array(ADDON_DATABASE, ADDON_FLOWTQM)
varWizardName = Array(FILE_DATABASE, FILE_FLOWTQM)
varWizardArgs = Array("", "")

ElseIf bDatabase And Not (bFlowTQM) And Not (bColorSchemes) Then
iMnuItems = 1 'Number of menu items to be added
varMenuItemCaption = Array(ADDON_DATABASE)
varWizardName = Array(FILE_DATABASE)
varWizardArgs = Array("")

ElseIf bFlowTQM And Not (bDatabase) And Not (bColorSchemes) Then
iMnuItems = 1 'Number of menu items to be added
varMenuItemCaption = Array(ADDON_FLOWTQM)
varWizardName = Array(FILE_FLOWTQM)
varWizardArgs = Array("")

Else 'neither addon is available
Exit Sub

End If

'----------------------------------------------------------


'Check if Document is in place
If ThisDocument.InPlace Then End

'This checks if user has applied a custom UI file _
to the template and/or if a custom UI that is specific _
to Visio has been applied.

'Check if there are file custom menus
If ThisDocument.CustomMenus Is Nothing Then
'Check if there are Visio custom menus
If Visio.Application.CustomMenus Is Nothing Then
'Use the Built-in menus
Set visUIobj = Visio.Application.BuiltInMenus
Else
'use the Visio custom menus
Set visUIobj = Visio.Application.CustomMenus
'save to a file
strPath = Visio.Application.Path & CUST_UI_FILENAME
visUIobj.SaveToFile (strPath)
'Set the existing custom UI for the document
ThisDocument.CustomMenusFile = strPath
'Grab this document's UI object
Set visUIobj = ThisDocument.CustomMenus
'Delete the newly created temp file
Kill Visio.Application.Path & CUST_UI_FILENAME
ThisDocument.ClearCustomMenus
End If

Else
'Use the file custom menus
Set visUIobj = ThisDocument.CustomMenus
End If

Set visMenuSetsObj = visUIobj.MenuSets

'Create menuset object for specified _
window context- (Drawing window menus)
Set visMenuSetObj = visMenuSetsObj.ItemAtID(visUIObjSetDrawing)
Set visMenusObj = visMenuSetObj.Menus

'Get the "Tools" menu from the Active Toolbar _
& if it does not exist, add it for this document.
For iMenucount = 0 To visMenusObj.Count - 1
Set visMenuObj = visMenusObj.Item(iMenucount)
If visMenuObj.Caption = MENU_TOOLS Then
GoTo MenuOK
End If
Next iMenucount
bNoTools = True
Set visMenuObj = visMenusObj.AddAt(visMenusObj.Count)
visMenuObj.Caption = MENU_TOOLS

MenuOK:
'Add menu items in menu
For iItemCount = 1 To iMnuItems

Set visMenuItemObj = visMenuObj.MenuItems.AddAt(iItemCount - 1)

'Set the caption and mini help text
visMenuItemObj.Caption = varMenuItemCaption(iItemCount - 1)
visMenuItemObj.MiniHelp = RUN & Left(varWizardName(iItemCount - 1), Len(varWizardName(iItemCount - 1)) - 4)

'set the name of addon to run
visMenuItemObj.AddOnName = varWizardName(iItemCount - 1)

Next iItemCount

'Add the separator bar to menu(if Tools menu exists) _
after added Menu items.
If bNoTools = False Then
Set visMenuItemSep = visMenuObj.MenuItems.AddAt(iItemCount - 1)
visMenuItemSep.Caption = "-"
End If
'Set the new custom UI for the document
ThisDocument.SetCustomMenus visUIobj

EXIT_ON_ERROR:

End Sub


Private Sub Document_DocumentCreated(ByVal doc As Visio.IVDocument)
Dim i As Integer

For i = 1 To Addons.Count
If Addons(i).Name = "Powerpointize" Then
Addons(i).RUN ("")
End If
Next i

AddMenuItem

End Sub

Private Sub Document_DocumentOpened(ByVal doc As Visio.IVDocument)

AddMenuItem

End Sub