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,348 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
  • 9
  • 7
  • 4
20 Comments
 
LVL 12

Expert Comment

by:chandru_sol
Comment Utility
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
Comment Utility
Can you create rules and folders?

0
 
LVL 12

Expert Comment

by:chandru_sol
Comment Utility
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
 
LVL 11

Author Comment

by:bsharath
Comment Utility
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
Comment Utility
it is a vbs script
0
 
LVL 11

Author Comment

by:bsharath
Comment Utility
What will the script do?
0
 
LVL 12

Expert Comment

by:chandru_sol
Comment Utility
Create a folder in Outlook inbox
0
 
LVL 11

Author Comment

by:bsharath
Comment Utility
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
Comment Utility
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
Comment Utility
Thanks Chris...
0
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
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
Comment Utility
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
Comment Utility
SPoke too soon ... I am seeing an issue!  BRB

Chris
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Set OWA language and time zone in Exchange for individuals, all users or per database.
Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
This video walks the viewer through the process of creating Hyperlinks for the web and other documents. Select the "Insert" tab: Click "Hyperlink":  Type "http://" followed by a web address to reference a website or navigate to a document to ref…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

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

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now