Outlook VBA script that is triggered by sent message rule

[jdabramson]

I would like to alter the script below to allow a outbound message trigger rule to create a task based text in a outbound email. Here's the proposed rule

Apply this rule after I send the message with "specific words" in the subject or body and on this computer only run "a script"

My goal is to have a the script,below, triggered via rule or VBA code when I type zzwo in the message. This will create a task from the email message in a "waiting on reply" category. The script, below, will allow me to create an inbound rule to trigger it; however, inbound rules do not show this script as an option to run.




' Set the string comparison method to Text ("AAA" = "aaa").
Option Compare Text

Sub CreateWOTaskFromEmail(MyMail As Outlook.MailItem)
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim objTask As Outlook.TaskItem
Dim categories As String
Dim addRecipient As Boolean
Dim regex
Dim matches, customSubject, subject

' Configuration options
categories = "Waiting on Reply"
addRecipient = True

strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
Set objTask = Application.CreateItem(olTaskItem)
objTask.Attachments.Add MyMail
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "zzwo (.*)"
regex.IgnoreCase = True
regex.Global = True
Set matches = regex.Execute(olMail.Body)
If matches.Count <> 0 Then
customSubject = matches(0).submatches(0)
Else
customSubject = ""
End If
If customSubject <> "" Then
subject = customSubject
Else
subject = olMail.subject
End If

With objTask
If addRecipient Then
.subject = olMail.Recipients.Item(1) & ": " & subject
Else
.subject = subject
End If
.categories = categories
.Body = olMail.Body
End With
objTask.Save

Set objTask = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub

' Wrapper that gets the current item and calls the previous function, to use as a macro
Sub CreateWOTaskFromEmailMacro()
Dim curMail As Outlook.MailItem
Set curMail = GetCurrentItem()
Call CreateWOTaskFromEmail(curMail)
End Sub

Function GetCurrentItem() As Object
Dim objApp As Outlook.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
Case Else
' anything else will result in an error, which is
' why we have the error handler above
End Select

Set objApp = Nothing
End Function

My thanks for your replies and Diego Zamboni for the original code.

[gmayor]

Rather than use a rule use the Item Send event. Put the following in the ThisOutlookSession module

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
CreateWOTaskFromEmail Item
End Sub

The modify your macro (which goes in an ordinary module) as follows.
I have not tested your Regex search, but that aside it works when you send a message.


Sub CreateWOTaskFromEmail(MyMail As Outlook.MailItem)
Dim strID As String
'Dim olNS As Outlook.NameSpace
'Dim olMail As Outlook.MailItem
Dim objTask As Outlook.TaskItem
Dim categories As String
Dim addRecipient As Boolean
'Dim regex
Dim matches, customSubject, subject

' Configuration options
categories = "Waiting on Reply"
addRecipient = True

strID = MyMail.EntryID
'Set olNS = Application.GetNamespace("MAPI")
'Set olMail = olNS.GetItemFromID(strID)
Set objTask = Application.CreateItem(olTaskItem)
objTask.Attachments.Add MyMail
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "zzwo (.*)"
regex.IgnoreCase = True
regex.Global = True
Set matches = regex.Execute(MyMail.Body)
If matches.Count <> 0 Then
customSubject = matches(0).submatches(0)
Else
customSubject = ""
End If
If customSubject <> "" Then
subject = customSubject
Else
subject = MyMail.subject
End If

With objTask
If addRecipient Then
.subject = MyMail.Recipients.Item(1) & ": " & subject
Else
.subject = subject
End If
.categories = categories
.Body = MyMail.Body
End With
objTask.Save

Set objTask = Nothing
'Set olMail = Nothing
'Set olNS = Nothing
End Sub

[jdabramson]

Rather than use a rule use the Item Send event. Put the following in the ThisOutlookSession module

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
CreateWOTaskFromEmail Item
End Sub

The modify your macro (which goes in an ordinary module) as follows.
I have not tested your Regex search, but that aside it works when you send a message.


Sub CreateWOTaskFromEmail(MyMail As Outlook.MailItem)
Dim strID As String
'Dim olNS As Outlook.NameSpace
'Dim olMail As Outlook.MailItem
Dim objTask As Outlook.TaskItem
Dim categories As String
Dim addRecipient As Boolean
'Dim regex
Dim matches, customSubject, subject

' Configuration options
categories = "Waiting on Reply"
addRecipient = True

strID = MyMail.EntryID
'Set olNS = Application.GetNamespace("MAPI")
'Set olMail = olNS.GetItemFromID(strID)
Set objTask = Application.CreateItem(olTaskItem)
objTask.Attachments.Add MyMail
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "zzwo (.*)"
regex.IgnoreCase = True
regex.Global = True
Set matches = regex.Execute(MyMail.Body)
If matches.Count <> 0 Then
customSubject = matches(0).submatches(0)
Else
customSubject = ""
End If
If customSubject <> "" Then
subject = customSubject
Else
subject = MyMail.subject
End If

With objTask
If addRecipient Then
.subject = MyMail.Recipients.Item(1) & ": " & subject
Else
.subject = subject
End If
.categories = categories
.Body = MyMail.Body
End With
objTask.Save

Set objTask = Nothing
'Set olMail = Nothing
'Set olNS = Nothing
End Sub

I plugged the code in and all works great. Thank you for your help.

[jdabramson]

I stand corrected.. The code you suggested creates a task for every sent message. Not just messages with "zzwo" in the body

[gmayor]

If you only want the task to be created when "zzwo" is in the mesage body then I wouild simplify the main macro it to

Option Explicit
Sub CreateWOTaskFromEmail(MyMail As Outlook.MailItem)
Dim strSubject As String
Dim objTask As Outlook.TaskItem
Dim sCategories As String
Dim bAddRecipient As Boolean

' Configuration options
sCategories = "Waiting on Reply"
bAddRecipient = True
On Error GoTo err_Handler
If InStr(1, MyMail.Body, "zzwo") > 0 Then
Set objTask = Application.CreateItem(olTaskItem)
objTask.Attachments.Add MyMail
strSubject = MyMail.subject
With objTask
If bAddRecipient Then
.subject = MyMail.Recipients.Item(1) & ": " & strSubject
Else
.subject = strSubject
End If
.categories = sCategories
.Body = MyMail.Body
End With
objTask.Save
End If
lbl_Exit:
Set objTask = Nothing
Exit Sub
err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub

[jdabramson]

Thank you and it is working as intended. However, I now get an MVB error when responding to and sending meeting requests. Please see below.

16021

I select debug and here's what pops up.

16022

Thank you for your time and attention. Sorry for your troubles with this thread.

[gmayor]

You need an error trap to ensure that the messages processed are mail items e.g.


Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If TypeName(Item) = "MailItem" Then
CreateWOTaskFromEmail Item
End If
End Sub