Create Search folder in VBA

Search folder are a very cool tool but difficult to use. We have exchange on-premises 2016 and outlook 2016 professional.

I would like to write a VBA to: add in mail context menu the option: "create search folder #senderdomain". This should Create a search folder called #domain including all the email sent from and to that domain.

I found that code:
Sub Application_ItemContextMenuDisplay(ByVal CommandBar As Office.CommandBar, ByVal Selection As Selection)
    Dim objCommandBarButton As Office.CommandBarButton
    'Add "New Search Folder" to the ContactItem's Context Menu
    If (Selection.Count = 1) And (Selection.Item(1).Class = olContact) Then
       Set objCommandBarButton = CommandBar.Controls.Add(msoControlButton)
       With objCommandBarButton
           .Style = msoButtonIconAndCaption
           .Caption = "New Search Folder"
           .FaceId = 1744
           .OnAction = "Project1.ThisOutlookSession.CreateRelatedSearchFolder"
       End With
    End If
End Sub

Sub CreateRelatedSearchFolder()
    Dim objContact As Outlook.ContactItem
    Dim strEmailAddress As String
    Dim strDisplayName As String
    Dim strFilter As String
    Dim strFrom1, strFrom2, strTo1, strTo2 As String
    Dim strScope As String
    Dim objSearch As Outlook.Search
    'Get the selected contact
    Set objContact = Application.ActiveExplorer.Selection.Item(1)
    'Get the contact's main email address and display name
    strEmailAddress = objContact.Email1Address
    strDisplayName = objContact.Email1DisplayName
    If strEmailAddress = "" Then
       Exit Sub
    End If
    strFrom1 = ""
    strFrom2 = ""
    strTo1 = ""
    strTo2 = ""
    'Specify the search filter
    strFilter = "((""" & strFrom1 & """ CI_STARTSWITH '" & strEmailAddress & "' OR """ & strFrom2 & """ CI_STARTSWITH '" & strEmailAddress & "')" & " OR (""" & strTo1 & """CI_STARTSWITH '" & strEmailAddress & "' OR """ & strTo2 & """ CI_STARTSWITH '" & strEmailAddress & "' OR """ & strTo1 & """ CI_STARTSWITH '" & strDisplayName & "' OR """ & strTo2 & """ CI_STARTSWITH '" & strDisplayName & "' ))"
    'Specify the folders to be searched
    strScope = "'" & Application.Session.GetDefaultFolder(olFolderInbox).FolderPath & "','" & Application.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "'"
    'Search all mails from or to the specific contact
    Set objSearch = Application.AdvancedSearch(strScope, strFilter, True, "SearchFolder")
    'Save the search results to a search folder
    objSearch.Save (objContact.FullName)
End Sub

Open in new window

It does somethink somehow similar but I can't understand the syntax. Can someone help me or give me some link to learn how to do so?

Thank you so much
Giovanni AAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Neil FlemingConsultant and developerCommented:
You can achieve what you want more simply, I think, by using so-called SQL DASL syntax for the search.

Below is my modified version of the code you posted, (without the code that adds the button).

Sub DomainFolderFromContact()
    Dim oContact As Outlook.ContactItem
    Dim sEmail As String
    Dim sFilter As String
    Dim iPos As Long
    Dim sScope As String
    Dim oSearch As Outlook.Search
    'Get the selected contact
    Set oContact = Application.ActiveExplorer.Selection.Item(1)
    'Get the contact's main email address
    sEmail = oContact.Email1Address
    'abort if no email address
    If sEmail = "" Then Exit Sub
    'extract the domain from the email address
    iPos = InStr(sEmail, "@")
    sEmail = Right(sEmail, Len(sEmail) - iPos)
    'abort if nota valid domain
    If sEmail = "" Then Exit Sub
    'create a DASL filter, using urn schemas
    'chr(34) inserts a hard quote symbol - " - in the filter
    'this creates a filter which looks both for emails from the domain extracted (eg or sent to it
    sFilter = Chr(34) & "urn:schemas:httpmail:fromemail" & Chr(34) & " LIKE '%" & sEmail & "%' OR " & _
              Chr(34) & "urn:schemas:httpmail:displayto" & Chr(34) & " LIKE '%" & sEmail & "%'"

    'Specify the folders to be searched (same as your example .. gets the inbox and the sent mail folders
    sScope = "'" & Application.Session.GetDefaultFolder(olFolderInbox).FolderPath & "','" & Application.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "'"
    'Create the search as a searchfolder
    Set oSearch = Application.AdvancedSearch(sScope, sFilter, True, "SearchFolder")
    'Save the search results under the contact's full name
    oSearch.Save (oContact.fullName)
End Sub

Open in new window

Does this help?

There is a nice article on DASL searching in Andrew Dewlin's MSDN blog here.

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Neil FlemingConsultant and developerCommented:
Just noticed you wanted to save the search as the domain name with a hashtag.

so the last line of the code should in fact read

oSearch.Save ("#" & sEmail)
End Sub

Open in new window

Giovanni AAuthor Commented:
Thankyou. How can I fix the rest of the code?
Neil FlemingConsultant and developerCommented:
which other code? Do you mean the first routine which adds the button?
Giovanni AAuthor Commented:
Ok, this works good!  Thankyou  I still need
1) add the button
2) I want to start from the recived email not from the contact saved (if is possible)
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today

From novice to tech pro — start learning today.