• Status: Solved
  • Priority: High
  • Security: Public
  • Views: 188
  • Last Modified:

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 = "http://schemas.microsoft.com/mapi/proptag/0x0065001f"
    strFrom2 = "http://schemas.microsoft.com/mapi/proptag/0x0042001f"
    strTo1 = "http://schemas.microsoft.com/mapi/proptag/0x0e04001f"
    strTo2 = "http://schemas.microsoft.com/mapi/proptag/0x0e03001f"
    '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 A
Giovanni A
  • 3
  • 2
2 Solutions
Neil FlemingIndependent consultantCommented:
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 hotmail.com) 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.
Neil FlemingIndependent consultantCommented:
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 FlemingIndependent consultantCommented:
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)
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now