Stephen’s Scribble Pad

By Stephen 　http://smmeyer.com/scribble/?p=90

Hey, I return to the topic of Visio customisation to implement actual buttons for my macros instead of using the time wasting menu drill down through Tools/Macros/Document1/Module1/My_Macro.

I didn’t do this before because there is no functionality to add macro’s as buttons in the  Customise Toolbar dialog. However I have now learned that it is possible to do this programmatically. So, based on my past discoveries, I now have 2 new tools handy on my Standard toolbar: the first sets a fixed grid of 2mm x 2mm; the second fits the drawing page to the contents. FYI this saves me 8 clicks + 2 keystrokes; and 5 clicks respectively.

I added all the code to the BASFLO_M.VSS shape template as I normally only use this.

The following goes in the ThisDocument object to create the buttons as soon as the shape template (or a drawing created using the shape template) is opened:

Private Sub Document_DocumentOpened(ByVal doc As IVDocument)
AddGridButton
AddFitPageButton
End Sub

The code to create the buttons goes into a Module along with the procedures (the actual macro’s you want to run):

Public Sub AddGridButton()
On Error Resume Next
' Check for existing custom button by the Tag property to avoid creating duplicates
Set checkControl = Application.CommandBars.FindControl(, , "GridButton")
' If no button with this Tag exists then it's OK to create the button
If checkControl.Tag = "" Then
Dim standardBuiltInBar As CommandBar
Dim newButton As CommandBarButton
Dim picPicture As IPictureDisp
Dim picMask As IPictureDisp
' Add the new control to the Standard toolbar
Set standardBuiltInBar = Application.CommandBars("Standard")
Set newButton = standardBuiltInBar.Controls.Add(msoControlButton)
' Get new button face as custom 16x16 Bitmap consisting of a Picture and a transparency Mask
Set picPicture = stdole.StdFunctions.LoadPicture("C:\Program Files\Microsoft Office\Visio11\1033\grid.bmp")
Set picMask = stdole.StdFunctions.LoadPicture("C:\Program Files\Microsoft Office\Visio11\1033\gridmask.bmp")

With newButton
.Picture = picPicture
.Mask = picMask
' OnAction syntax is PROJECT_NAME!MODULE_NAME.PROCEDURE_NAME
.OnAction = "BASFLO_M!CustomProcedures.SetStandardGrid"
.Tag = "GridButton"
.TooltipText = "2mm Fixed Grid"
.Visible = True
End With
End If
End Sub

Public Sub AddFitPageButton()
On Error Resume Next
' Check for existing custom button by the Tag property to avoid creating duplicates
Set checkControl = Application.CommandBars.FindControl(, , Tag:="FitPageButton")
' If no button with this Tag exists then it's OK to create the button
If checkControl.Tag = "" Then
Dim standardBuiltInBar As CommandBar
Dim newButton As CommandBarButton
Dim picPicture As IPictureDisp
Dim picMask As IPictureDisp

' Add the new control to the Standard toolbar
Set standardBuiltInBar = Application.CommandBars("Standard")
Set newButton = standardBuiltInBar.Controls.Add(msoControlButton)
' Get new button face as custom 16x16 Bitmap consisting of a Picture and a transparency Mask
Set picPicture = stdole.StdFunctions.LoadPicture("C:\Program Files\Microsoft Office\Visio11\1033\fitpage.bmp")
Set picMask = stdole.StdFunctions.LoadPicture("C:\Program Files\Microsoft Office\Visio11\1033\fitpagemask.bmp")

With newButton
.Picture = picPicture
.Mask = picMask
' OnAction syntax is PROJECT_NAME!MODULE_NAME.PROCEDURE_NAME
.OnAction = "BASFLO_M!CustomProcedures.FitPageToDrawing"
.Tag = "FitPageButton"
.TooltipText = "Fit Page to Drawing"
.Visible = True
End With
End If
End Sub

Public Sub SetStandardGrid()
Dim UndoScopeID2 As Long
UndoScopeID2 = Application.BeginUndoScope("Set Grid")
Dim vsoShape1 As Shape
Set vsoShape1 = Application.ActiveWindow.Page.PageSheet
vsoShape1.CellsSRC(visSectionObject, visRowRulerGrid, visXGridDensity).FormulaU = "0"
vsoShape1.CellsSRC(visSectionObject, visRowRulerGrid, visYGridDensity).FormulaU = "0"
vsoShape1.CellsSRC(visSectionObject, visRowRulerGrid, visXGridSpacing).FormulaU = "2 mm"
vsoShape1.CellsSRC(visSectionObject, visRowRulerGrid, visYGridSpacing).FormulaU = "2 mm"
Application.EndUndoScope UndoScopeID2, True
End Sub

Public Sub FitPageToDrawing()
Dim vsoShape As Visio.Shape
Dim UndoScopeID1 As Long
If Application.ActivePage.PageSheet.Shapes.Count = 0 Then Exit Sub
UndoScopeID1 = Application.BeginUndoScope("Fit Page")
Application.ActiveWindow.SelectAll
Set vsoShape = ActiveWindow.Selection.Group
h = vsoShape.Cells("Height")
w = vsoShape.Cells("Width")
Application.ActivePage.Background = False
Application.ActivePage.BackPage = ""
Application.ActivePage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).FormulaU = Str(w)
Application.ActivePage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).FormulaU = Str(h)
Application.ActivePage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageDrawSizeType).FormulaU = "1"
Application.ActivePage.PageSheet.CellsSRC(visSectionObject, visRowPrintProperties, visPrintPropertiesPageOrientation).FormulaU = "2"
Application.ActiveWindow.Page.CenterDrawing
Application.EndUndoScope UndoScopeID1, True
vsoShape.Ungroup
End Sub


You will need to download and save the following custom button face Bitmaps into C:\Program Files\Microsoft Office\Visio**\1033 if you want to try out my example.
gridmask.bmp
grid.bmp
fitpagemask.bmp
fitpage.bmp