Sort Message Into Multiple Categories

[harperakm]

Hi, I'm trying to sort incoming mail into multiple categories according to keywords in the message body. Currently it's only tagging one category per email, even if multiple keywords are present.

I'm new to vba so this is probably completely wrong, but below is what I have so far (also my code does have indents but I couldn't paste it correctly here):

Sub Categorize(Item As Outlook.MailItem)
Select Case LCase(Item.Body)
Case "keyword1"
Item.Categories = "Category 1"
End Select
Item.Save
Select Case LCase(Item.Body)
Case "keyword2"
Item.Categories = "Category 2"
End Select
Item.Save
Select Case LCase(Item.Body)
Case "keyword3"
Item.Categories = "Category 3"
End Select
Item.Save
End Sub

Help please!

Thanks!

[gmayor]

Use the # symbol to add code tags to retain the format.
You appear to be trying to equate the keyword with the whole of the body rather than contained within it and you are trying to reset the category each time rather than append categories.
The following should be closer


Sub Categorize(Item As Outlook.MailItem)
Dim strCategories As String
Const sKeywords As String = "keyword1|keyword2|keyword3"

If InStr(1, LCase(Item.Body), Split(sKeywords, "|")(0)) > 0 Then
If Not strCategories = "" Then
strCategories = strCategories & ","
End If
strCategories = strCategories & "Category 1"
End If
If InStr(1, LCase(Item.Body), Split(sKeywords, "|")(1)) > 0 Then
If Not strCategories = "" Then
strCategories = strCategories & ","
End If
strCategories = strCategories & "Category 2"
End If
If InStr(1, LCase(Item.Body), Split(sKeywords, "|")(2)) > 0 Then
If Not strCategories = "" Then
strCategories = strCategories & ","
End If
strCategories = strCategories & "Category 3"
End If
Item.Categories = strCategories
lbl_Exit:
Exit Sub
End Sub