Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
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
Medium Priority
?
1,359 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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
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 2000 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

Learn Veeam advantages over legacy backup

Every day, more and more legacy backup customers switch to Veeam. Technologies designed for the client-server era cannot restore any IT service running in the hybrid cloud within seconds. Learn top Veeam advantages over legacy backup and get Veeam for the price of your renewal

Question has a verified solution.

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

If you troubleshoot Outlook for clients, you may want to know a bit more about the OST file before doing your next job. IMAP can cause a lot of drama if removed in the accounts without backing up.
The core idea of this article is to make you acquainted with the best way in which you can export Exchange mailbox to PST format.
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
There are cases when e.g. an IT administrator wants to have full access and view into selected mailboxes on Exchange server, directly from his own email account in Outlook or Outlook Web Access. This proves useful when for example administrator want…

604 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