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.