Question : Outlook Macro to create rules of particular users to move the mails to the relevant same named folders.

Hi,

Outlook Macro to create rules of particular users to move the mails to the relevant same named folders.
I have 100 + folders in the inbox on my PST with the same names as the senders.

If Holy Devis sends a mail to me then the folder name is also Holy Devis. Can a macro when run create rules as to move mails to the relevant folders once they are in.

Regards
Sharath

Answer : Outlook Macro to create rules of particular users to move the mails to the relevant same named folders.

bsharath,

The code below will do this. Create a rule that fires for all messages and set it as the first rule in line. Set the rule's action to run a script and select this script.

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:

           
           
             Sub FileMessages(Item As Outlook.MailItem)
    Dim strFoldername As String, _
        olkFolder As Outlook.folder
    Select Case Item.SenderName
        'Add the following two lines for each sender you want to file messages for.
        Case "Holy Devis"
            strFoldername = "Holy Devis"
        Case "John Doe"
            strFoldername = "John Doe"
    End Select
    If strFoldername <> "" Then
        Set olkFolder = OpenOutlookFolder(strFoldername)
        Item.Move olkFolder
    End If
    Set olkFolder = Nothing
End Sub
 
Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function
 
Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        olkFolder As Outlook.MAPIFolder
    On Error GoTo ehOpenOutlookFolder
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        If Left(strFolderPath, 1) = "\" Then
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        End If
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olkFolder) Then
                Set olkFolder = Session.Folders(varFolder)
            Else
                Set olkFolder = olkFolder.Folders(varFolder)
            End If
        Next
        Set OpenOutlookFolder = olkFolder
    End If
    On Error GoTo 0
    Exit Function
ehOpenOutlookFolder:
    Set OpenOutlookFolder = Nothing
    On Error GoTo 0
End Function

           
         

Open in New Window Select All