使用 vba 创建一个新的功能区选项卡，该选项卡仅显示选择某些形状

Question

我想显示一个新的功能区选项卡，该选项卡仅在我选择所需的形状时出现。我知道使用 Microsoft Office 的自定义 UI 编辑器或 VBA 使用以下示例制作普通选项卡：

Dim oToolbar As CommandBar
    Dim oButton As CommandBarButton
    Dim MyToolbar As String

    ' Give the toolbar a name
    MyToolbar = "Kewl Tools"

    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

    ' 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

    ' 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:

但我想让它在某些时刻出现和消失。例如，在 Powerpoint 中，当您选择一个视频时，会出现 2 个带有视频选项的新标签（格式和播放）。当您选择另一个不是视频的形状时，此选项卡会消失，其他选项卡会显示您选择的形状的正确选项，当您不选择任何形状时，这些特殊选项卡就会消失。

是否可以使用 VBA 制作？

Answer 1

是的，这是可能的。要实现这一点，您需要执行三项主要操作。

1. 在加载项中启用事件以捕获对形状的选择。当形状选择事件触发时，将调用它来确定形状是否是您想要显示的标签等。
2. 在定义功能区的 XML 中确保您有一个“可见”回调函数。
3. “可见”回调函数的 VBA 代码。

例如

在名为“功能区”的模块中

Private theRibbon As IRibbonUI 'Holds a variable for the ribbon when loaded on startup
Private MyTag As String        'A variable to tell the ribbon to show or what Tag to hide

'Callback for the Ribbon loading from XML
Public Sub RibbonOnLoad(Ribbon As IRibbonUI)
    Set theRibbon = Ribbon
    MyTag = "show"
End Sub

'Get visible callback function.
Sub GetVisible(control As IRibbonControl, ByRef visible)
    If MyTag = "show" Then
        visible = True
    Else
        If control.Tag Like MyTag Then
            visible = True
        Else
            visible = False
        End If
    End If
End Sub

'This is a custom sub that invalidates the ribbon as needed.  
'When invalidated it has to redraw itself
Sub RefreshRibbon(Tag As String)
    MyTag = Tag
    If theRibbon Is Nothing Then
        MsgBox "Error, Save/Restart your presentation"
    Else
        theRibbon.Invalidate
    End If
End Sub

在名为“事件”的模块中

'Define the new events class
Dim cPPTEvent As New clsEvents

Sub Auto_Open()
    'Enable the events when the aad-in is loaded
    Set cPPTEvent.PPTEvent = Application
End Sub

Sub Auto_Close()
    'Disable when it is closed
    Set cPPTEvent.PPTEvent = Nothing
    Set cPPTEvent = Nothing
End Sub

在名为“clsEvents”的类模块中。这将检查范围内的形状，如果有任何是电影媒体类型，则选项卡将显示在功能区上，否则将被隐藏。

Public WithEvents PPTEvent As Application

Private Sub PPTEvent_WindowSelectionChange(ByVal Sel As Selection)
    Dim ppCurShape As PowerPoint.Shape

    If Sel.Type = ppSelectionNone Then
        RefreshRibbon ""
        Exit Sub
    End If

    For Each ppCurShape In Sel.ShapeRange
        If ppCurShape.Type = msoMedia Then
            If ppCurShape.MediaType = ppMediaTypeMovie Then
                RefreshRibbon "show"
                Exit Sub
            End If
        End If
    Next

    RefreshRibbon ""
End Sub

当然还有功能区 XML 代码（取自底部的第一个参考）

    <customUI onLoad="RibbonOnLoad" xmlns="http://schemas.microsoft.com/office/2006/01/customui">
      <ribbon>
        <tabs>
          <tab id="MyCustomTab" label="My Tab" insertAfterMso="TabHome" getVisible="GetVisible" tag="MyPersonalTab" >
           <group id="customGroup1" label="Group 1">
              <button id="customButton1" label="Caption 1" size="normal" onAction="Macro1" imageMso="DirectRepliesTo" />
              <button id="customButton2" label="Caption 2" size="normal" onAction="Macro2" imageMso="AccountMenu" />
              <button id="customButton3" label="Caption 3" size="normal" onAction="Macro3" imageMso="RegionLayoutMenu" />
            </group>
            <group id="customGroup2" label="Group 2">
              <button id="customButton4" label="Caption 4" size="normal" onAction="Macro4" imageMso="TextAlignGallery" />
              <button id="customButton5" label="Caption 5" size="normal" onAction="Macro5" imageMso="PrintPreviewClose" />
              <button id="customButton6" label="Caption 6" size="normal" onAction="Macro6" imageMso="PrintPreviewShrinkOnePage" />
              <separator id="MySeparator1" />
              <button id="customButton7" label="Caption 7" size="large" onAction="Macro7" imageMso="ReviewPreviousComment" />
            </group>
            <group id="customGroup3" label="Group 3">
              <menu id="MyDropdownMenu" label="My Menu" size="large" imageMso="TextAlignGallery"  >
                <button id="customButton8" label="Caption 8"  onAction="Macro8" imageMso="TextAlignGallery" />
                <button id="customButton9" label="Caption 9"  onAction="Macro9" imageMso="TextAlignGallery" />
                <button id="customButton10" label="Caption 10"  onAction="Macro10" imageMso="TextAlignGallery" />
                <button id="customButton11" label="Caption 11"  onAction="Macro11" imageMso="TextAlignGallery" />
                <button id="customButton12" label="Caption 12"  onAction="Macro12" imageMso="TextAlignGallery" />
              </menu>
            </group>
          </tab>
        </tabs>
      </ribbon>
    </customUI>

更多阅读：

• 隐藏选项卡和控件：http://msdn.microsoft.com/en-us/library/ee390805%28v=office.11%29#odc_office2007_DisplayHideRibbonControls_ChangingVisibilityRibbonTabs
• Powerpoint 事件（感谢 Steve）：http://www.pptfaq.com/FAQ00004_Make_your_VBA_code_in_PowerPoint_respond_to_events.htm
• 您可以捕获的事件列表：http://officeone.mvps.org/vba/events_version.html