PowerPoint VBA надстройка с несколькими кнопками

Question

Я добавил надстройку PowerPoint с одной кнопкой на панель инструментов на ленте через VBA, и она работает, как задумано.Однако, когда я пытаюсь добавить более одной кнопки, надстройка будет отображать только последнюю кнопку в моем коде.Каждая кнопка появляется на панели инструментов и работает нормально, если это единственная кнопка в коде.Например, в приведенном ниже коде единственная кнопка, которую я в итоге вижу, это «Button3».Есть идеи, что я делаю не так?

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

Answer 1

Кажется вероятным, что во время отладки вы добавили какой-то экземпляр панели инструментов AddIn, и теперь он существует в этом состоянии.Таким образом, вы должны убедиться, что вы всегда удаляете его , прежде чем пытаться добавить его.

При некоторых других незначительных ре-факторингах я бы порекомендовал так:

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

Вам необходимо добавить следующие две процедуры:

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