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.

Capture1.PNG

I select debug and here's what pops up.

Capture2.jpg

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