bugfix> vba > 投稿

VBA経由でリボンのツールバーにボタンが1つあるPowerPointアドインを追加しましたが、意図したとおりに機能します。ただし、複数のボタンを追加しようとすると、アドインはコードの最後のボタンのみを表示します。各ボタンはツールバーに表示され、コード内の唯一のボタンであれば正常に機能します。たとえば、次のコードでは、最終的に表示されるボタンは「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

回答 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
    
    

    次の2つの手順を追加する必要があります。

    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
    
    

あなたの答え