Reputation: 15
I've added a PowerPoint addin with one button to a toolbar in my ribbon via VBA and it works as intended. However when I try to add more than one button, the addin will only display the last button in my code. Each button appears in the toolbar and works fine if it is the only button in the code. For instance in the code below, the only button that I end up seeing is 'Button3'. Any ideas what I'm doing wrong?
Sub Auto_Open()
Dim oToolbar As CommandBar
Dim oButton As CommandBarButton
Dim MyToolbar As String
' Give the toolbar a name
MyToolbar = "Helpful Stuff"
On Error Resume Next
' so that it doesn't stop on the next line if the toolbar's already there
' Create the toolbar; PowerPoint will error if it already exists
Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
Position:=msoBarFloating, Temporary:=True)
If Err.Number <> 0 Then
' The toolbar's already there, so we have nothing to do
Exit Sub
End If
On Error GoTo ErrorHandler
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "This is my first button"
'Tooltip text when mouse if placed over button
.Caption = "Do Button1 Stuff"
'Text if Text in Icon is chosen
.OnAction = "Button1"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 52
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' Repeat the above for as many more buttons as you need to add
' Be sure to change the .OnAction property at least for each new button
With oButton
.DescriptionText = "This is my second button"
'Tooltip text when mouse if placed over button
.Caption = "Do Button2 Stuff"
'Text if Text in Icon is chosen
.OnAction = "Button2"
'Runs the Sub Button2() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 51
' chooses icon #51 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
With oButton
.DescriptionText = "This is my third button"
'Tooltip text when mouse if placed over button
.Caption = "Do Button3 Stuff"
'Text if Text in Icon is chosen
.OnAction = "Button3"
'Runs the Sub Button3() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 50
' chooses icon #50 from the available Office icons
End With
' You can set the toolbar position and visibility here if you like
' By default, it'll be visible when created. Position will be ignored in PPT 2007 and later
oToolbar.Top = 150
oToolbar.Left = 150
oToolbar.Visible = True
NormalExit:
Exit Sub ' so it doesn't go on to run the errorhandler code
ErrorHandler:
'Just in case there is an error
MsgBox Err.Number & vbCrLf & Err.Description
Resume NormalExit:
End Sub
Sub Button1()
Dim oSl As Slide
Dim oSh As Shape
Dim sFontName As String
' Edit this as needed:
sFontName = "Calibri (Body)"
With ActivePresentation
For Each oSl In .Slides
For Each oSh In oSl.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
.TextFrame.TextRange.Font.Name = sFontName
End If
End If
End With
Next
Next
End With
End Sub
Sub Button2()
' PPT coordinates are Singles rather than Doubles
Dim sngNewWidth As Single
Dim sngNewHeight As Single
Dim oSh As Shape
' Start with the height/width of first shape in selection
With ActiveWindow.Selection.ShapeRange
sngNewWidth = .Item(1).Width
sngNewHeight = .Item(1).Height
End With
' First find the smallest shape in the selection
For Each oSh In ActiveWindow.Selection.ShapeRange
If oSh.Width < sngNewWidth Then
sngNewWidth = oSh.Width
End If
If oSh.Height < sngNewHeight Then
sngNewHeight = oSh.Height
End If
Next
' now that we know the height/width of smallest shape
For Each oSh In ActiveWindow.Selection.ShapeRange
oSh.Width = sngNewWidth
oSh.Height = sngNewHeight
Next
End Sub
Sub Button3()
Dim w As Double
Dim h As Double
Dim obj As Shape
w = 0
h = 0
' Loop through all objects selected to assign the biggest width and height to w and h
For i = 1 To ActiveWindow.Selection.ShapeRange.Count
Set obj = ActiveWindow.Selection.ShapeRange(i)
If obj.Width > w Then
w = obj.Width
End If
If obj.Height > h Then
h = obj.Height
End If
Next
' Loop through all objects selected to resize them if their height or width is smaller than h/w
For i = 1 To ActiveWindow.Selection.ShapeRange.Count
Set obj = ActiveWindow.Selection.ShapeRange(i)
If obj.Width < w Then
obj.Width = w
End If
If obj.Height < h Then
obj.Height = h
End If
Next
End Sub
Upvotes: 1
Views: 1019
Reputation: 53663
It seems likely what happened during your debugging is that you've added some instance of the AddIn toolbar, and now it exists in that state. So, you need to ensure that you always remove it before attempting to add it.
With some other minor re-factoring, I would recommend like so:
Option Explicit
' Give the toolbar a name
Const MyToolbar As String = "Helpful Stuff"
Dim oToolbar As CommandBar
Sub Auto_Open()
Dim oButton As CommandBarButton
Call AddMe
On Error GoTo ErrorHandler
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "This is my first button" 'Tooltip text when mouse if placed over button
.Caption = "Do Button1 Stuff" 'Text if Text in Icon is chosen
.OnAction = "Button1" 'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon ' Button displays as icon, not text or both
.FaceId = 52 ' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' Repeat the above for as many more buttons as you need to add
' Be sure to change the .OnAction property at least for each new button
With oButton
.DescriptionText = "This is my second button" 'Tooltip text when mouse if placed over button
.Caption = "Do Button2 Stuff" 'Text if Text in Icon is chosen
.OnAction = "Button2" 'Runs the Sub Button2() code when clicked
.Style = msoButtonIcon ' Button displays as icon, not text or both
.FaceId = 51 ' chooses icon #51 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
With oButton
.DescriptionText = "This is my third button" 'Tooltip text when mouse if placed over button
.Caption = "Do Button3 Stuff" 'Text if Text in Icon is chosen
.OnAction = "Button3" 'Runs the Sub Button3() code when clicked
.Style = msoButtonIcon ' Button displays as icon, not text or both
.FaceId = 50 ' chooses icon #50 from the available Office icons
End With
NormalExit:
Exit Sub ' so it doesn't go on to run the errorhandler code
ErrorHandler:
'Just in case there is an error
MsgBox Err.Number & vbCrLf & Err.Description
Resume NormalExit:
End Sub
You'll need to add these two procedures:
Private Sub RemoveMe()
' Removes the toobar if it already exists:
On Error Resume Next
CommandBars(MyToolbar).Delete
End Sub
Private Sub AddMe()
' If the toolbar already exists, remove it
Call RemoveMe
Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
Position:=msoBarFloating, Temporary:=True)
' You can set the toolbar position and visibility here if you like
' By default, it'll be visible when created. Position will be ignored in PPT 2007 and later
oToolbar.Top = 150
oToolbar.Left = 150
oToolbar.Visible = True
End Sub
Upvotes: 1