在 Outlook 2003 中创建右键单击上下文菜单

Question

我已经能够在 Outlook 2003 的顶部菜单栏中创建一个新菜单，但我希望在用户右键单击电子邮件时执行相同的操作（但如果可能，不要在界面中的其他任何位置）。

这是我得到的：

Sub AddMenus()
    Dim cbMainMenuBar As CommandBar
    Dim cbcCustomMenu As CommandBarControl
    Dim cbcTest As CommandBarControl
    Dim iHelpMenu as Integer

    Set cbMainMenuBar = Application.ActiveExplorer.CommandBars.ActiveMenuBar
    iHelpMenu = cbMainMenuBar.Controls("&?").index

    Set cbcCustomMenu = cbMainMenuBar.Controls.Add(Type:=msoControlPopup, before:=iHelpMenu)
    cbcCustomMenu.caption = "Menu &Name"

    Set cbcTest = cbcCustomMenu.Controls.Add(Type:=msoControlPopup)
    cbcTest.caption = "&Test"

    With cbcTest.Controls.Add(Type:=msoControlButton)
                .caption = "&Submenu item"
                .OnAction = "macro"
    End With
    With cbcTest.Controls.Add(Type:=msoControlButton)
                .caption = "Another submenu item"
                .OnAction = "macro"
    End With
    With cbcCustomMenu.Controls.Add(Type:=msoControlButton)
                .caption = "About"
                .OnAction = "macro"
    End With
End Sub

右键单击时我必须进行哪些更改才能使其正常工作？

Answer 1

这个问题的最终答案可以在这里找到：http://www.outlookcode.com/codedetail.aspx?id=314

这是我在删除一些我不需要的代码/cmets 后得到的：

Option Explicit

Private WithEvents ActiveExplorerCBars As CommandBars
Private WithEvents ContextButton As CommandBarButton     
Private IgnoreCommandbarsChanges As Boolean

Private Sub Application_Startup()
    Set ActiveExplorerCBars = ActiveExplorer.CommandBars
End Sub

Private Sub ActiveExplorerCBars_OnUpdate()
    Dim bar As CommandBar

    If IgnoreCommandbarsChanges Then Exit Sub

    On Error Resume Next
    Set bar = ActiveExplorerCBars.Item("Context Menu")
    On Error GoTo 0

    If Not bar Is Nothing Then
        AddContextButton bar
    End If
End Sub

Sub AddContextButton(ContextMenu As CommandBar)
    Dim b As CommandBarButton
    Dim subMenu As CommandBarControl
    Dim cbcCustomMenu As CommandBarControl, cbcLink As CommandBarControl

    Set ContextMenu = ActiveExplorerCBars.Item("Context Menu")

    'Unprotect context menu
    ChangingBar ContextMenu, Restore:=False

    'Menu
    Set cbcCustomMenu = ContextMenu.Controls.Add(Type:=msoControlPopup)
    cbcCustomMenu.caption = "&Menu"

    'Link in Menu
    Set cbcLink = cbcCustomMenu.Controls.Add(Type:=msoControlButton)
    cbcLink.caption = "Link 1"
    cbcLink.OnAction = "macro"

    'Reprotect context menu
    ChangingBar ContextMenu, Restore:=True
End Sub

'Called once to prepare for changes to the command bar, then again with
'Restore = true once changes are complete.
Private Sub ChangingBar(bar As CommandBar, Restore As Boolean)
  Static oldProtectFromCustomize, oldIgnore As Boolean

  If Restore Then
    'Restore the Ignore Changes flag
    IgnoreCommandbarsChanges = oldIgnore

    'Restore the protect-against-customization bit
    If oldProtectFromCustomize Then bar.Protection = bar.Protection And msoBarNoCustomize

  Else
    'Store the old Ignore Changes flag
    oldIgnore = IgnoreCommandbarsChanges
    IgnoreCommandbarsChanges = True

    'Store old protect-against-customization bit setting then clear
    'CAUTION: Be careful not to alter the property if there is no need,
    'as changing the Protection will cause any visible CommandBarPopup
    'to disappear unless it is the popup we are altering.
    oldProtectFromCustomize = bar.Protection And msoBarNoCustomize
    If oldProtectFromCustomize Then bar.Protection = bar.Protection And Not msoBarNoCustomize
  End If
End Sub

Answer 2

我不再安装 Outlook 2003 并且 Outlook 2010 不会让您以同样的方式弄乱右键菜单。所以这编译，希望接近你需要做的。

在编写任何代码之前，您需要显示隐藏的项目，我认为，以获得几个对象的 Intellisense。在 2010 年，ActiveExporer 和 ActiveInspector 对象 - 这是 Outlook 中的两种视图，例如查看所有电子邮件或查看单个电子邮件 - 被隐藏。要取消隐藏它们，请在 VBE 中单击 F2 进入对象资源管理器，然后右键单击任意位置并选中“显示隐藏的项目”。

所以现在你可以开始编码了：

首先，您需要一种方法来确定您感兴趣的右键单击菜单的名称。这会尝试向每个菜单添加一个按钮，按钮的标题是菜单的名称和索引。它首先重置菜单，以免创建多个这样的按钮。该按钮应位于菜单的底部。这些按钮是临时的，这意味着下次打开 Outlook 时它们会消失：

Sub GetCommandBarNames()
Dim cbar As Office.CommandBar
Dim cbarButton As Office.CommandBarButton

For Each cbar In ActiveInspector.CommandBars
    On Error Resume Next
    cbar.Reset
    Set cbarButton = cbar.Controls.Add(Type:=msoControlButton, temporary:=True)
    With cbarButton
        .Caption = cbar.Name
        .Style = msoButtonCaption
        .Visible = True
    End With
    On Error GoTo 0
Next cbar
For Each cbar In ActiveExplorer.CommandBars
    On Error Resume Next
    cbar.Reset
    Set cbarButton = cbar.Controls.Add(Type:=msoControlButton, temporary:=True)
    With cbarButton
        .Caption = cbar.Name & "-" & cbar.Index
        .Style = msoButtonCaption
        .Visible = True
    End With
    On Error GoTo 0
Next cbar
End Sub

运行后，右键单击 Outlook 并获取所需菜单的名称。它将是最后一个按钮上破折号之前的部分。假设它是“foobar”。

你应该能够做到这一点：

Sub AddButton()
Dim cbar As Office.CommandBar
Dim cbarButton As Office.CommandBarButton

Set cbar = ActiveExplorer.CommandBars("foobar")    'or maybe it's ActiveInspector
Set cbarButton = cbar.Controls.Add(Type:=msoControlButton, temporary:=True)
With cbarButton
    .Caption = "&Submenu item"
    .OnAction = "macro"
    .Style = msoButtonCaption
    'etc.
End With
'do the next button
Set cbarButton = cbar.Controls.Add(Type:=msoControlButton, temporary:=True)
'...
End Sub

就像我说的那样，我这样做有点盲目，但我在 Excel 中做过很多次（我什至写了两个插件），所以如果这不起作用，我应该能够让你到达那里.