Outlook macro - categorise e-mails by part of subject-CodePudding

I am trying to make a macro in Outlook that will put a category on all the e-mails that have the same first 15 characters of the subject.

I have a script (which I borrowed here Macro in Outlook to delete duplicate emails- thank you to @sarah for asking the question and to @AndyDaSilva52 for answering it) that compares subject and body of e-mails, finds duplicates and moves them to the Deleted Items.

I would like to modify it in a way that it compares only first 15 characters of subject and categorizes them instead of deleting them.

Any help would be much appreciated. Here is the code:

Option Explicit

'Set a reference to the Microsoft Scripting Runtime from Tools, References.

Sub CategorizeDuplicateEmailsInSelectedFolder()

Dim i As Long
Dim n As Long
Dim Message As String
Dim Items As Object
Dim AppOL As Object
Dim NS As Object
Dim Folder As Object

Set Items = CreateObject("Scripting.Dictionary")

'Initialize and instance of Outlook
Set AppOL = CreateObject("Outlook.Application")

'Get the MAPI Name Space
Set NS = AppOL.GetNamespace("MAPI")

'Allow the user to select a folder in Outlook
Set Folder = NS.PickFolder

'Get the count of the number of emails in the folder
n = Folder.Items.Count

'Check each email starting from the last and working backwards to 1
'Loop backwards to ensure that the deleting of the emails does not interfere with subsequent items in the loop
For i = n To 1 Step -1

    On Error Resume Next
    'Load the matching criteria to a variable
    'This is setup to use the Subject
    Message = Folder.Items(i).Subject <- this part needs to be modifed

        'Check a dictionary variable for a match
        If Items.Exists(Message) = True Then
        'If the item has previously been added then categorize this duplicate
        Folder.Items(i).Categories = "Blue category" <- this part needs to be modifed
    Else
        'In the item has not been added then add it now so subsequent matches will be categorized
        Items.Add Message, True
End If

Next i

ExitSub:

'Release the object variables from memory
Set Folder = Nothing
Set NS = Nothing
Set AppOL = Nothing

End Sub

Thank you in advance!

CodePudding user response：

I am trying to make a macro in Outlook that will put a category on all the e-mails that have the same first 15 characters of the subject.

To find all items with the same Subject string (with first 15 characters) you can use the Find/FindNext or Restrict methods of the Items class. Read more about these methods in the following articles:

Also you may consider using the Folder.GetTable method which obtains a Table object that contains items filtered by filter. GetTable returns a Table with the default column set for the folder type of the parent Folder. To modify the default column set, use the Add, Remove, or RemoveAll methods of the Columns collection object.

Sub RestrictTableOfInbox() 
    Dim oT As Outlook.Table 
    Dim strFilter As String 
    Dim oRow As Outlook.Row 
     
    'Construct filter for Subject containing 'your_15_characters' 
    Const PropTag  As String = "https://schemas.microsoft.com/mapi/proptag/" 
    strFilter = "@SQL=" & Chr(34) & PropTag  _ 
        & "0x0037001E" & Chr(34) & " ci_phrasematch 'your_15_characters'" 
     
    'Do search and obtain Table on Inbox 
    Set oT = Application.Session.GetDefaultFolder(olFolderInbox).GetTable(strFilter) 
     
    'Print Subject of each returned item 
    Do Until oT.EndOfTable 
        Set oRow = oT.GetNextRow 
        Debug.Print oRow("Subject") 
    Loop 
End Sub

Also you may take a look at the Application.AdvancedSearch method which performs a search based on a specified DAV Searching and Locating (DASL) search string. The key benefits of using the AdvancedSearch method in Outlook are:

The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.

Read more about that method in the Advanced search in Outlook programmatically: C#, VB.NET article.

CodePudding user response：

This turned out to be trickier than it first appeared.

Option Explicit

'Set a reference to the Microsoft Scripting Runtime from Tools, References.

Sub CategorizeDuplicateEmailsInSelectedFolder()

Dim i As Long
Dim n As Long

Dim startSubject As String
Dim dictItems As Object

Dim pFolder As Object
Dim pFolderItems As Items
Dim msgObj As mailItem

Set dictItems = CreateObject("Scripting.Dictionary")

'Allow the user to select a folder in Outlook
Set pFolder = Session.PickFolder
If pFolder Is Nothing Then Exit Sub

Set pFolderItems = pFolder.Items

'Get the count of the number of emails in the folder
n = pFolderItems.Count

pFolderItems.Sort "[ReceivedTime]", True

'Check each email starting from the oldest
For i = n To 1 Step -1

    If TypeName(pFolderItems(i)) = "MailItem" Then
    
        Set msgObj = pFolderItems(i)
        
        'Load the matching criteria to a variable
        'This is setup to use the Subject
        'Message = Folder.Items(i).subject ' <- this part needs to be modifed
        startSubject = Left(msgObj.subject, 15)
        Debug.Print startSubject
        
        'Check a dictionary variable for a match
        If dictItems.Exists(startSubject) = True Then
            'If the item has previously been added then categorize this duplicate
            
            'pFolderItems(i).categories = "Blue category" ' <- This did not save
            
            msgObj.categories = "Blue category" ' <- This could be saved
            msgObj.Save
            
        Else
            'In the item has not been added then add it now so subsequent matches will be categorized
            dictItems.Add startSubject, True
        End If
    End If
Next i

End Sub

https://excelmacromastery.com/vba-error-handling/#On_Error_Resume_Next
"There are specific occasions when this is useful. Most of the time you should avoid using it."