How to Trap Outlook Events from Excel Application

Question

I have a workbook that at least 15 people use and update periodically that contains client information with emails within column H3:H1500. Using the Worksheet_FollowHyperlink event, we can send emails through our Outlook accounts that are pre-written and dependent upon what day of the week an order is requested (M-F, Saturday and Sunday) and the code works just fine to generate messages. My main problem is in tracking responses to clients. I tried having a sub that recorded date (NOW function) and Environ("username") whenever the hyperlink within column H was selected, but as I have the e-mail sub set to .Display (so people can make any last minute adjustments, if needed) it only records who selected the hyperlink (which, apparently happens a lot on accident when the message is never actually sent). I had found several threads throughout this forum and others that reference creating a Class module and I implemented one that was used to see if it would work in my code, but by adding it, the entire email sub was rendered useless so I reverted back to the old form. As I am not extremely experienced in VBA (I have gotten this far due to help and trial and error), I realize that some of my choices of code may seem silly, and if there are better ways to do this, I am open to it - I just know that, this sheet works mostly for now and I hope it can be improved, if possible.

My current email sub is:

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim Body1, Body2, Body3 As String
Dim olApp As Outlook.Application
Dim OlMail As Outlook.MailItem

On Error Resume Next
Application.EnableEvents = False

Set olApp = GetObject(,"Outlook.Application")

Do While olApp.Inspectors.Count = 0
DoEvents

Loop

Set olMail = olApp.Inspectors.Item(1).CurrentItem

With olMail

Body1 = "This is my weekday text"
Body2 = "This is my Saturday text"
Body3 = "This is my Sunday text"

.Subject = "Subject"
.Attachemnts.Add "C:\Path"
.CC = Target.Range.Offset(0,4).Text
.BCC = ""

If Target.Range.Offset(0,5).Text = "No" Then
.Body1
If Target.Range.Offset(0,5).Text = "Yes" Then
.Body2
If Target.Range.Offset(0,5).Text = "Sunday" Then
.Body3

.Display
End With

forward:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Description
Resume forward
End Sub

[The above code is in the Excel VBE, the following code is in the Outlook VBE, I should have included that before starting - it is working fine for me right now, so I am not sure why it is not compiling...]

Function GetCurrentItem() As Object
Dim objApp As Application

Set objApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function

Any help is appreciated!

Answer 1

You are trying to work with events in outlook, from an Excel thread, really really interesting Q and I didn't know if it would be possible. I think this will get you started.

I am hoping to be able to track the user and date of who accessed the email hyperlink and actually sent it.

PROBLEM: The hyperlink is opening another application (Outlook), over which you don't have full control. And at least from the VBA side, you do NOT have control over the Outlook events.

I thought there may be an easier way to hack around a solution but that was a dead end, you had hinted at class object, so I figured I had an idea that might work... never done this before though, so it's a work in progress.

To solve this, I settle on an approach that does:

1. Kills the hyperlinks so that they don't automatically launch Outlook
2. Use the SelectionChange event to send the mail via VBA rather than the FollowHyperlink event
3. Create a custom event handler class object for an Outlook MailItem which will trap the _Send event, which you can then use to log the details of the send.

Here are the codes/instructions:

Create a class object called cMailItem and put this code inside it:

Option Explicit
'MailItem event handler class
Public WithEvents m As Outlook.MailItem

Public Sub Class_initialize()

    Set m = olApp.CreateItem(0)

End Sub

Private Sub m_Send(Cancel As Boolean)

        Debug.Print "Item was sent by " & Environ("Username") & " at " & Now()
        Call ReleaseTrap

End Sub

In a STANDARD code module (I call this one HelperFunctions but the name doesn't matter) put this code, which will set a flag for our cMailItem Event Handler class and also contains the function which returns the instance of Outlook Application.

Option Explicit
'#################
'NOTE: The TrapEvents should be called when the Forms are initialized
'NOTE: The ReleaseTrap should be called when the Forms are closed
Public olApp As Outlook.Application
Public cMail As New cMailItem
Public TrapFlag As Boolean

Sub TrapEvents()
If Not TrapFlag Then
   Set olApp = GetApplication("Outlook.Application")
   TrapFlag = True
End If
End Sub

Sub ReleaseTrap()
If TrapFlag = True Then
   Set olApp = Nothing
   Set cMail = Nothing
   TrapFlag = False
End If
End Sub

Function GetApplication(Class As String) As Object
'Handles creating/getting the instance of an application class
Dim ret As Object

On Error Resume Next

Set ret = GetObject(, Class)
If Err.Number <> 0 Then
    Set ret = CreateObject(Class)
End If

Set GetApplication = ret

On Error GoTo 0

End Function

Now, part of the problem is the way that the hyperlink follow takes precedence over other events. To avoid that, I use some code to "kill" the hyperlinks. They will "link" only to the cell wherein they reside, but they will still contain the text for the email address.

Instead of using the FollowHyperlink event, I use the SelectionChange event to call another procedure which sends the mail.

In your WORKSHEET module, put the following event handlers AND the SendMail procedure:

Option Explicit

Private Sub Worksheet_Activate()
'Converts Mailto hyperlinks so that they do NOT
' automatically open Outlook MailItem

    Dim h As Hyperlink

    For Each h In ActiveSheet.Hyperlinks
        If h.Address Like "mailto:*" Then
            h.ScreenTip = h.Address
            h.Address = ""
            h.SubAddress = h.Range.Address
        End If

    Next

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Disable Excel events
Application.EnableEvents = False

    If Target.Cells.Count <> 1 Then GoTo EarlyExit
    If Target.Hyperlinks.Count <> 1 Then GoTo EarlyExit

    'Send mail to the specified recipient/etc.
    Call SendMail(Target)

EarlyExit:
'Re-enable events:
Application.EnableEvents = True

End Sub
Private Sub SendMail(Target As Range)

Dim Body1$, Body2$, Body3$
Dim OlMail As Outlook.MailItem
Const OLMAILITEM As Long = 0

'Set our Outlook event trap
Call TrapEvents

'CREATE the mailitem
Set OlMail = cMail.m 

With OlMail

    Body1 = "This is my weekday text"
    Body2 = "This is my Saturday text"
    Body3 = "This is my Sunday text"

    .To = Target.Text
    .Subject = "Subject"
    '.Attachemnts.Add "C:\Path"
    .CC = Target.Offset(0, 4).Text
    .BCC = ""

    .Display
End With


End Sub

NOTE ON REVISED ANSWER

I revised this from the original solution which used an Outlook Application event handler class, which was limited by the fact that it would trap ANY item_send event, this was problematic because multi-tasking users would send false positives. The revised solution uses an event handler for the MailItem object which is created at run-time, and should avoid that pitfall.

THERE MAY BE OTHER LIMITATIONS

For example, this method does not really handle "multiple" emails, so if the user clicks one link, and then another, there will only be ONE email that exists and can be tracked. If you need to handle multiple emails, use a public Collection of this class object, which I did for this similar question.

As I said, this is the first time I've ever attempted to use a WithEvents handler between two applications. I've used theme in single-application Add-Ins, etc., but never binding two applications in this manner, so it's uncharted territory for me.