问题
I'm already able to create a new menu in the top menubar of Outlook 2003 but would like to do the same when the user right-click on an email (but not anywhere else in the interface if possible).
Here is what I got:
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
What do I have to change to make this works when right-clicking?
回答1:
The definitive answer to the problem can be found here: http://www.outlookcode.com/codedetail.aspx?id=314
Here is what I come with after removing some of the code/comments I didn't need:
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
回答2:
I no longer have Outlook 2003 installed and Outlook 2010 doesn't let you mess with right-click menus the same way. So this compiles and is, hopefully close to what you need to do.
Before writing any code, you'll want to show hidden items, I think, to get the Intellisense for a couple of objects. In 2010 the ActiveExporer and ActiveInspector objects - which are the two types of view in Outlook, e.g., looking at all you email, or looking at a single email - are hidden. To unhide them, go into the Object Explorer by clicking F2 in the VBE, and right-click just about anywhere and check "Show Hidden Items".
So now you're ready to code:
First you need a way to determine the name of the right-click menu you are interested in. This tries to add a button to every menu, with the button's caption being the name and index of the menu. It resets the menu first, so as to not create more than one such button. The button should be at the bottom of the menu. The buttons are temporary, meaning they'll be gone the next time you open 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
After running this, right-click in Outlook and get the name of the menu you want. It will be the part before the dash on the last button. Let's say it's "foobar".
You should then be able to do this:
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
Like I say, I'm doing this a bit blind, but I've done it many times in Excel (I even wrote two addins), so if this doesn't work, I should be able to get you there.
来源：https://stackoverflow.com/questions/15075384/create-a-right-click-context-menu-in-outlook-2003