Solved

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

Posted on 2007-12-02
20
1,351 Views
Last Modified: 2012-08-14
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
0
Comment
Question by:bsharath
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 9
  • 7
  • 4
20 Comments
 
LVL 12

Expert Comment

by:chandru_sol
ID: 20394823
script can be used to create folders in inbox and the rules can be used to move to folders
0
 
LVL 11

Author Comment

by:bsharath
ID: 20394849
Can you create rules and folders?

0
 
LVL 12

Expert Comment

by:chandru_sol
ID: 20394897
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
Comprehensive Backup Solutions for Microsoft

Acronis protects the complete Microsoft technology stack: Windows Server, Windows PC, laptop and Surface data; Microsoft business applications; Microsoft Hyper-V; Azure VMs; Microsoft Windows Server 2016; Microsoft Exchange 2016 and SQL Server 2016.

 
LVL 11

Author Comment

by:bsharath
ID: 20395174
Should i put this in the outlook Module.?Or use it as a vbs.
What will this script do?
0
 
LVL 12

Expert Comment

by:chandru_sol
ID: 20396737
it is a vbs script
0
 
LVL 11

Author Comment

by:bsharath
ID: 20396775
What will the script do?
0
 
LVL 12

Expert Comment

by:chandru_sol
ID: 20396807
Create a folder in Outlook inbox
0
 
LVL 11

Author Comment

by:bsharath
ID: 20396852
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
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 20409947
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
 
LVL 11

Author Comment

by:bsharath
ID: 20409965
Thanks Chris...
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 20410166
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
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 20410195
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
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 20410213
SPoke too soon ... I am seeing an issue!  BRB

Chris
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
ID: 20410265
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
 
LVL 11

Author Comment

by:bsharath
ID: 20410313
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
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 20410321
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
 
LVL 11

Author Closing Comment

by:bsharath
ID: 31412192
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
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 20410398
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
 
LVL 11

Author Comment

by:bsharath
ID: 20410430
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
 
LVL 11

Author Comment

by:bsharath
ID: 22103855
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

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

When you have clients or friends from around the world, it becomes a challenge to arrange a meeting or effectively manage your time. This is where Outlook's capability to show 2 time zones in one calendar comes in handy.
How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question