带有多个按钮的Powerpoint VBA插件

Question

我已经通过VBA向我的功能区中的工具栏添加了一个带有一个按钮的PowerPoint插件，它按预期工作。但是，当我尝试添加多个按钮时，插件只会显示我代码中的最后一个按钮。每个按钮都会出现在工具栏中，如果它是代码中的唯一按钮，则工作正常。例如，在下面的代码中，我最终看到的唯一按钮是＆＃39; Button3＆＃39;。我有什么想法我做错了吗？

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