Outlook Macro to search the Inbox alone and if the sender has more than 20 mails sent to me has to create a folder and move the mails to the folder

Hi,

Outlook Macro to search the Inbox alone and if the sender has more than 20 mails sent to me has to create a folder and move the mails to the folder.Is there a way a macro can do this when run.
The folder has to be created below the inbox with the senders name.

Regards
Sharath
LVL 11
bsharathAsked:
Who is Participating?
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Sorry, i've modified it to use teh sender name rather than email address as I noticed with some commercial emails the sender more accurately groups the emails.

Also processed the emails start to fininsh ... thereforre when movinf=g the email this mucked up the process.

Latest tests are much improved so see what you think

Chris
Sub moveExcessEmails()
 
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim targetFolder As Outlook.MAPIFolder
Dim olMailItems As Outlook.Items
Dim mailCount As Integer
Dim mailCounter As Integer
Dim senderCounter As Integer
Dim mai As Outlook.mailitem
Dim strFilter As String
    On Error Resume Next
    
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set MyFolder = objNS.GetDefaultFolder(olFolderInbox)
'    For Each mai In MyFolder.Items
    For mailCounter = MyFolder.Items.Count To 1 Step -1
        Set mai = MyFolder.Items(mailCounter)
'        Debug.Print mai.SenderEmailAddress & vbTab & mai.SenderName
        strFilter = "[SenderName] = " & append_quotes(mai.SenderName)
        Set olMailItems = objNS.GetDefaultFolder(olFolderInbox).Items.Restrict(strFilter)
        mailCount = olMailItems.Count
        If mailCount >= 20 Then
            Set targetFolder = findFolder(olMailItems.Item(1).SenderName)
            Debug.Print olMailItems.Item(1).SenderName & ", (" & mailCount & " items)."
            For senderCounter = mailCount To 1 Step -1
                olMailItems.Item(senderCounter).Move targetFolder
            Next
        End If
    Next
    
Set olMailItems = Nothing
Set objNS = Nothing
Set olApp = Nothing
Set MyFolder = Nothing
 
End Sub
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
Function findFolder(sender As String) As Outlook.MAPIFolder
Dim str_folder As String
Dim ol_app As Outlook.Application
Dim OL_namespace As Outlook.NameSpace
Dim OL_Folders As Outlook.Folders
Dim Required_Folder As Outlook.MAPIFolder
Dim arr_folders() As String
Dim nest_count As Integer
 
    str_folder = "personal folders/inbox/" & sender
    str_folder = "personal folders/inbox/" & "movefolder"
    
    On Error Resume Next
    str_folder = Replace(str_folder, "/", "\")
    If Right(str_folder, 1) = "\" Then str_folder = Left(str_folder, Len(str_folder) - 1)
    arr_folders() = Split(str_folder, "\")
    Set ol_app = CreateObject("outlook.application")
    Set OL_namespace = ol_app.GetNamespace("MAPI")
    Set Required_Folder = OL_namespace.Folders.Item(arr_folders(0))
    If Not Required_Folder Is Nothing Then
        For nest_count = 1 To UBound(arr_folders)
            Set OL_Folders = Required_Folder.Folders
            Set Required_Folder = Nothing
            Set Required_Folder = OL_Folders.Item(arr_folders(nest_count))
            If Required_Folder Is Nothing Then Set Required_Folder = OL_Folders.Add(arr_folders(nest_count))
        Next
    End If
    Set findFolder = Required_Folder
    Set ol_app = Nothing
    Set OL_namespace = Nothing
    Set OL_Folders = Nothing
    Set Required_Folder = Nothing
End Function

Open in new window

0
 
chandru_solCommented:
script can be used to create folders in inbox and the rules can be used to move to folders
0
 
bsharathAuthor Commented:
Can you create rules and folders?

0
Cloud Class® Course: Microsoft Office 2010

This course will introduce you to the interfaces and features of Microsoft Office 2010 Word, Excel, PowerPoint, Outlook, and Access. You will learn about the features that are shared between all products in the Office suite, as well as the new features that are product specific.

 
chandru_solCommented:
try this script for creating folders. This is a vbscript

Set objOutlook = CreateObject("Outlook.Application")
Set myNameSpace = objOutlook.GetNamespace("MAPI")
Set myInboxFolder = myNameSpace.GetDefaultFolder(6)
Set myNewFolder = myInboxFolder.Folders.Add("Myfolder")

regards
Chandru
0
 
bsharathAuthor Commented:
Should i put this in the outlook Module.?Or use it as a vbs.
What will this script do?
0
 
chandru_solCommented:
it is a vbs script
0
 
bsharathAuthor Commented:
What will the script do?
0
 
chandru_solCommented:
Create a folder in Outlook inbox
0
 
bsharathAuthor Commented:
But how can this help me in what i want.
I have a script that can create folders as per the txt file.I have the names in the txt file.But what about the movement
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
I have most of the pieces to do what you are asking figured out ... I now need to try and collate them.  Hopefully I will have a response in a week or so ... unless you get a satisfactory solution in the meantime.

Chris
0
 
bsharathAuthor Commented:
Thanks Chris...
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Please try the following:  I have applied a reasonable degree of testing so I believe it works ok:

Chris
Sub moveExcessEmails()
 
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim targetFolder As Outlook.MAPIFolder
Dim olMailItems As Outlook.Items
Dim mailCount As Integer
Dim mailCounter As Integer
Dim mai As Outlook.mailitem
Dim strFilter As String
    On Error Resume Next
    
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set MyFolder = objNS.GetDefaultFolder(olFolderInbox)
    For Each mai In MyFolder.Items
        strFilter = "[SenderEmailAddress] = " & append_quotes(mai.SenderEmailAddress)
        Set olMailItems = objNS.GetDefaultFolder(olFolderInbox).Items.Restrict(strFilter)
        mailCount = olMailItems.Count
        If mailCount >= 20 Then
            Set targetFolder = findFolder(olMailItems.Item(1).SenderName)
            Debug.Print olMailItems.Item(1).SenderName & ", (" & mailCount & " items)."
            For mailCounter = mailCount To 1 Step -1
                olMailItems.Item(mailCounter).Move targetFolder
            Next
'            Stop
        End If
    Next
    
Set olMailItems = Nothing
Set objNS = Nothing
Set olApp = Nothing
Set MyFolder = Nothing
 
End Sub
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
Function findFolder(sender As String) As Outlook.MAPIFolder
Dim str_folder As String
Dim ol_app As Outlook.Application
Dim OL_namespace As Outlook.NameSpace
Dim OL_Folders As Outlook.Folders
Dim Required_Folder As Outlook.MAPIFolder
Dim arr_folders() As String
Dim nest_count As Integer
 
    str_folder = "personal folders/inbox/" & sender
    
    On Error Resume Next
    str_folder = Replace(str_folder, "/", "\")
    If Right(str_folder, 1) = "\" Then str_folder = Left(str_folder, Len(str_folder) - 1)
    arr_folders() = Split(str_folder, "\")
    Set ol_app = CreateObject("outlook.application")
    Set OL_namespace = ol_app.GetNamespace("MAPI")
    Set Required_Folder = OL_namespace.Folders.Item(arr_folders(0))
    If Not Required_Folder Is Nothing Then
        For nest_count = 1 To UBound(arr_folders)
            Set OL_Folders = Required_Folder.Folders
            Set Required_Folder = Nothing
            Set Required_Folder = OL_Folders.Item(arr_folders(nest_count))
            If Required_Folder Is Nothing Then Set Required_Folder = OL_Folders.Add(arr_folders(nest_count))
        Next
    End If
    Set findFolder = Required_Folder
    Set ol_app = Nothing
    Set OL_namespace = Nothing
    Set OL_Folders = Nothing
    Set Required_Folder = Nothing
End Function

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
wasnt as difficult as I feared to join them up ... before testing wouldnt be a bad idea to copy the pst file just in case!

Chris
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
SPoke too soon ... I am seeing an issue!  BRB

Chris
0
 
bsharathAuthor Commented:
Cris i just check but nothing happens.
I have the mails in the pst Personal folder not the mail box store.
So is there anything i need to change.
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Rank amateur or what ...

I failed to delete one of the test lines in the findfolder function, (I used a common folder to make it easier to re-instate the inbox for additional tests.  simply delete or comment out the following line:

    str_folder = "personal folders/inbox/" & "movefolder"

if you have already run the macro then select everything in the inbox/movefolder and drag them back to the inbox after disabling the erroneous line.

Chris
0
 
bsharathAuthor Commented:
Excellent Chris..

You have designed it so well without errors after a test i ran it on my live pst which had 39,000 mails and all the job was done in just 5 min
Thanks a lot for the help....
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
BSHARATH

Glad to help ... I enjoy new tasks and to achieve this involved figuring out some new techniques so it was genuinely a request I enjoyed working on.

Chris
0
 
bsharathAuthor Commented:
Chris & Chandru here is another Genuine post.See if you can help...
http://www.experts-exchange.com/Software/Office_Productivity/Groupware/Outlook/Q_22997550.html
0
 
bsharathAuthor Commented:
Chris. how are u.
Just one question on this post. Is there a way that i run the macro on any folder other than inbox and it creates folders below that like sub folders who have more than 20 mails...
if yes i shall post a new Q... This is like very useful for me please..
0
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.

All Courses

From novice to tech pro — start learning today.