Add to Right Click Menu

[LMS]

I found the following code that you put in ThisOutlookSession that adds to the right click menu the reply to an email that you select. Is there something to do in this code where it can add a macro that I use, or when I create a new Useform that is not related to a Module, in the ThisOutlookSesssion I add code to the ThisOutlookSession ..for example:

Public Sub runthis72()
Dim frm As New UserForm71
frm.Show

End Sub


And this code runs the Userform71. So can I add the runthis72 to the big code I will post. so it shows up in the right click menu?

Private Sub Application_ItemContextMenuDisplay( _
ByVal CommandBar As Office.CommandBar, _
ByVal Selection As Selection)
Dim objButton As CommandBarButton
Dim intButtonIndex As Integer
Dim intCounter As Integer

On Error GoTo ErrRoutine

' Ensure we have only one item selected.
If Selection.Count = 1 Then

' Ensure we have a MailItem selected.
If Selection.Item(1).Class = olMail Then
' Find the location of the Reply To All button.
For intCounter = 1 To CommandBar.Controls.Count
If CommandBar.Controls(intCounter).ID = 355 Then
intButtonIndex = intCounter
Exit For
End If
Next

' If we have a Reply To All button in the
' context menu, add a new button to support
' the ReplyToNoncopied routine.
If intButtonIndex <> 0 Then
' Create a new menu item and place it
' just after the Reply To All button
Set objButton = CommandBar.Controls.Add( _
msoControlButton, , , intButtonIndex)

' Configure the menu item.
With objButton
.Style = msoButtonIconAndCaption
.Caption = "Repl&y to Non-copied"
.Parameter = Selection.Item(1).EntryID
.FaceId = 355
' If you place this sample in a class module
' other than ThisOutlookSession, update this
' line of code to ensure that the OnAction
' property contains the correct project,
' class, and routine name.
.OnAction = "Project1.ThisOutlookSession.ReplyToNoncopied"
End With
End If
End If
End If

EndRoutine:
On Error GoTo 0
' Place clean-up code here.
Exit Sub

ErrRoutine:
MsgBox Err.Number & " - " & Err.Description, _
vbOKOnly Or vbCritical, _
"Application_ItemContextMenuDisplay"
GoTo EndRoutine
End Sub

 

[LMS]

I changed "If Selection.Item(1).Class = olMail Then" to "If Selection.Item(1).Class = olContact Then" and changed ".OnAction = "Project1.ThisOutlookSession.ReplyToNoncopied" to ".OnAction = "Project1.ThisOutlookSession.runthis72", and when I select a contact, it opens the Userform from the runthis72....

But, I change the code title the top, and of course the caption, and a different runthis48, it does not show up as a second one......so can we do that? And if I select more than one contact, it does not show the additional on the right click menu....so can we do that?

 

[LMS]

Believe it or not, I added to the code

Dim objButton2 As CommandBarButton and

With objButton2
.Style = msoButtonIconAndCaption
.Caption = "LinkedIn Marketing E-Mails"
.Parameter = Selection.Item(1).EntryID
.FaceId = 355
' If you place this sample in a class module
' other than ThisOutlookSession, update this
' line of code to ensure that the OnAction
' property contains the correct project,
' class, and routine name.
.OnAction = "Project1.ThisOutlookSession.runthis72"

End With

And it added the next runthis72 for the other userform......

So need to know what to change so it does the same when I select more than one contact.

 

[LMS]

Any update on this situation?

 

[Diane Poremsky]

you need to set up the selection and check each obj in the selection, something like this:

    Dim currentExplorer As Explorer
    Dim Selection As Selection
   
    Dim obj As Object
    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection

    On Error Resume Next

    For Each obj In Selection

        'Test for contact and not distribution list
        If obj.Class = olContact Then
            Set objContact = obj

            With objContact

            End With
        End If

for each obj in selection

 

[LMS]

Thanks much. Can you tell where to put what and what to delete as I repeat, I only do what you show me.

 

[Forum Admin]

I have no idea where it goes. Maybe replace the code that checks for the selection count?

' Ensure we have only one item selected.
If Selection.Count = 1 Then

' Ensure we have a MailItem selected.
If Selection.Item(1).Class = olMail Then
' Find the location of the Reply To All button.

 

[LMS]

As a favor, can you please copy my code, make the changes and post it, as I have no idea how to do it.

Thanks to the Smart Woman!!!

 

[Diane Poremsky]

Seriously, I have no idea and I'm just guessing. You need to try something and see if it works. It may not be possible, I don't know.

Private Sub Application_ItemContextMenuDisplay( _
ByVal CommandBar As Office.CommandBar, _
ByVal Selection As Selection)
Dim objButton As CommandBarButton
Dim intButtonIndex As Integer
Dim intCounter As Integer

On Error GoTo ErrRoutine

Dim currentExplorer As Explorer
Dim Selection As Selection

Dim obj As Object
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection

On Error Resume Next

For Each obj In Selection


' Ensure we have a MailItem selected.
If obj.Class = olMail Then
Set objmail = obj '(what are you calling the mail object?)

With objmail

'do all this stuff
' Find the location of the Reply To All button.
For intCounter = 1 To CommandBar.Controls.Count
If CommandBar.Controls(intCounter).ID = 355 Then
intButtonIndex = intCounter
Exit For
End If
Next


' when do, loop to the next
End With
End If


'rest of your code here

 

[LMS]

thanks..tried it...but did not work

 

[Diane Poremsky]

That was my best guess. I don't know if its possible or how to do it, sorry.