VBA - Auto create folder of sender of existing mail

[performer201]

Hi,
I have the following VBA code which works great for new mail, Can someone tell me how to modify it to run on existing mail?
solution would be for it to create a folder under inbox of the sender name and automatically move the email for me.
The code is currently in the ThisOutlookSession.
Appreciate your help. :) Cleaning up my inbox of 15,000 will be a dream :)

Thanks

Sam

____________________

Private WithEvents Items As Outlook.Items


Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace


' set object reference to default Inbox
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

____________________


Private Sub Items_ItemAdd(ByVal Item As Object)
' fires when new item added to default Inbox
' (per Application_Startup)


On Error GoTo ErrorHandler


Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String


' don't do anything for non-Mailitems
If TypeName(Item) <> "MailItem" Then GoTo ProgramExit


Set Msg = Item


' move received email to target folder based on sender name
senderName = Msg.senderName


If CheckForFolder(senderName) = False Then ' Folder doesn't exist
Set targetFolder = CreateSubFolder(senderName)
Else
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = _
objNS.GetDefaultFolder(olFolderInbox).Folders(senderName)
End If


Msg.Move targetFolder


ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

____________________


Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder


Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)


' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0


If Not FolderToCheck Is Nothing Then
CheckForFolder = True
End If


ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

____________________


Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder


Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)


Set CreateSubFolder = olInbox.Folders.Add(strFolder)


ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

____________________

[skatonni]

The simplest way should be to reuse the code.


Sub passSelectedItemsToExistingCode()
Dim selItems As Selection
Dim i As Long
Set selItems = ActiveExplorer.Selection
For i = selItems.count To 1 Step -1
Items_ItemAdd selItems(i)
Next
End Sub


I suggest you select some "reasonable" number of items not all 15,000 at once.