Capturing Send Variables without using Application_ItemSend in ThisOutlookSession

[adatabase]

Hello,

I want to place a custom button in the send window's ribbon which allows me to capture the sender, recipient, subject, body and date/time sent and pass these through to an Access database then send the email as normal.

I have found out how to get these variables using the Application_ItemSend event in ThisOutlookSession. However, I don't want it to happen each time, only when the user selects the Custom button instead of the standard Sent button.

Here's the code I've been using in ThisOutlookSession which has been getting the variables I need:

Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim thisMail As Outlook.MailItem
Dim senderEmail As Variant
Const PR_SMTP_ADDRESS As String = schemas.microsoft.com/mapi/proptag/0x39FE001E (have removed prefix to allow posting).

With Item
Debug.Print .subject
Debug.Print .body
Debug.Print .senderEmailAddress
Debug.Print "Sent On: " & Now()
Set recips = .recipients
For Each recip In recips
Set pa = recip.PropertyAccessor
Debug.Print pa.GetProperty(PR_SMTP_ADDRESS) 'recip.Name & " " &
Next
End With

Thanks in advance!

[gmayor]

The difference would be that instead of using the ThisOutlookSession and an event, you would use a macro in an ordinary module to process the current message - something along the lines of the following. Use the string variables to write to the Access database.

Dim recip As Outlook.Recipient
Dim Recips As Outlook.Recipients
Dim pa As Outlook.propertyAccessor
Dim olItem As Outlook.MailItem
Dim strEmail As String
Dim strSubject As String
Dim strBody As String
Dim strRecips As String
Dim strSent As String

Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

    On Error Resume Next
    Set olItem = ActiveExplorer.Selection.Item(1)
    With olItem
        strSubject = .Subject
'Debug.Print strSubject
        strBody = .Body
'Debug.Print strBody
        strEmail = .SenderEmailAddress
'Debug.Print strEmail
        strSent = "Sent On: " & Now()
'Debug.Print strSent
        Set Recips = .Recipients
        For Each recip In Recips
            Set pa = recip.propertyAccessor
            strRecips = pa.GetProperty(PR_SMTP_ADDRESS) & ","
        Next recip
        Do While Right(strRecips, 1) = ","
            strRecips = Left(strRecips, Len(strRecips) - 1)
        Loop
'Debug.Print strRecips
    End With

[adatabase]

Hi gmayor,
Thanks for your reply.
When I add that code to a custom button in the ribbon of the write window and then press that button it takes the information from the highlighted item in the inbox rather than the write window.

[gmayor]

Make the following changes

Dim recip As Outlook.Recipient
Dim Recips As Outlook.Recipients
Dim pa As Outlook.propertyAccessor
Dim olItem As Outlook.MailItem
Dim strEmail As String
Dim strSubject As String
Dim strBody As String
Dim strRecips As String
Dim strSent As String

Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

    On Error Resume Next
    If TypeName(ActiveWindow) = "Inspector" Then
        If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then
            Set olItem = ActiveInspector.currentItem
            With olItem
                strSubject = .Subject
                Debug.Print strSubject
                strBody = .Body
                Debug.Print strBody
                strEmail = .SenderEmailAddress
                Debug.Print strEmail
                strSent = "Sent On: " & Now()
                Debug.Print strSent
                Set Recips = .Recipients
                For Each recip In Recips
                    Set pa = recip.propertyAccessor
                    strRecips = pa.GetProperty(PR_SMTP_ADDRESS) & ","
                Next recip
                Do While Right(strRecips, 1) = ","
                    strRecips = Left(strRecips, Len(strRecips) - 1)
                Loop
                Debug.Print strRecips
            End With
        End If
    End If

[adatabase]

Hi Graham, That works great for everything except the .senderEmailAddress is "". I'm using Outlook 2016 with an Exchange account. How would I access the sender's email address in that situation?

[skatonni]

There may be another way to get the applicable email address but I believe sender information requires a send action.

With the caveat that global variables will impact other code if not carefully named/used, you could conditionally apply ItemSend code like this.

Public globalCustomSendFlag As Boolean

Sub customSend()
    globalCustomSendFlag = True
    ActiveInspector.currentItem.Send
End Sub

Private Sub application_itemsend(ByVal item As Object, Cancel As Boolean)

If globalCustomSendFlag = True Then
    Debug.Print SenderEmailAddress
End If

globalCustomSendFlag = False

End Sub

[adatabase]

Great, thanks that's got it.