none
Simple VBA script RRS feed

  • Question

  • I’m trying to create a rule in outlook, however the body of the email which I am comparing against is divided over a table making it difficult to accomplish with out of the box functionality. As such I am investigating the use of VBA script.

    The rule should basically check the email body for keywords “Quote Request Form” and “Urgency: 1-5  2”. As you can see below.

    Quote Request Form

    Urgency: 1-5

    2

    The rule should then flag a follow up and alert for two hours time and assign a custom category. Any suggestions?


    • Edited by jlb777 Wednesday, June 3, 2015 5:32 PM
    Wednesday, June 3, 2015 5:31 PM

Answers

  • If the table layout is as exactly shown then the following should do the job. Use the test macro to test a matching selected message, and if it doesn't work resurrect the message boxes which should indicate where the problem lies. Whwen you are happy, you can then add the macro to a rule.

    Sub CheckMessage(olItem As MailItem)
    Dim vText() As String
    Dim sText As String
    Dim iHrs As Integer
    Dim i As Long
    Dim LDate As Date
        sText = Replace(olItem.Body, Chr(160), Chr(32))
        vText = Split(sText, Chr(13))
        For i = 0 To UBound(vText)
            If Trim(vText(i)) = "Quote Request Form" Then
                'MsgBox vText(i) & vbCr & vText(i + 2) & vbCr & vText(i + 4)
                If InStr(1, vText(i + 2), "Urgency: 1-5") > 0 Then
                    'MsgBox "Found"
                    iHrs = Val(vText(i + 4))
                    With olItem
                        LDate = DateAdd("n", iHrs * 60, Now())
                        .FlagDueBy = LDate
                        .FlagRequest = "Call " & olItem.SenderName
                        .ReminderSet = True
                        .ReminderTime = LDate
                        .Categories = "Test" 'Custom category name
                        .Save
                    End With
                End If
                Exit For
            End If
        Next i
    lbl_Exit:
        Exit Sub
    End Sub
    
    Sub TestMsg()
    Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.Item(1)
        CheckMessage olMsg
    lbl_Exit:
        Exit Sub
    End Sub
    


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, June 4, 2015 11:58 AM