Auto Create and Sort to Folders???

[Marc Easy]

:dunno Hello,

I have a rather large mailbox (3-4gb in OL 2003 SP2) which has a ton of email I need and a ton I dont. It goes back 8 years. Id like to create a macro that will:

1) Look at an email address in my inbox and make a folder (if it dosent exist) with the email address as the name of the folder.

2) Sort the email to that folder

3) Move to the next email, repeat

Right now its spent 8 years being sorted by project (rather than email address)

This way I can just delete the whole folder for those I dont need!

Has this been done? Anybody have a clue how to start? Im not VBA literate but im a quick study.

thanks!

ME

[Oorang]

Welcome to the board:)
This should so about what you described.

Option Explicit

Public Sub SortToEmailFolders(Optional ByVal copyOnly As Boolean = False)
'---------------------------------------------------------------------------
' Procedure : SortToEmailFolders
' Author : Aaron Bush
' Date : 05/08/2008
' Purpose : Sorts all email in inbox into a folder named by the sender.
' Input(s) : copyOnly - If true, rather than moving email to folders, a
' copy of the email will be sent to the folder while
' leaving the original in the inbox.
'---------------------------------------------------------------------------
Const strMailItem_c As String = "MailItem"
Dim ns As Outlook.NameSpace
Dim mfMain As Outlook.MAPIFolder
Dim mfInbox As Outlook.MAPIFolder
Dim mfDstn As Outlook.MAPIFolder
Dim miCurnt As Outlook.MailItem
Dim objItem As Object
On Error GoTo Err_Hnd
Set ns = Outlook.Session
Set mfInbox = ns.GetDefaultFolder(olFolderInbox)
Set mfMain = mfInbox.parent
For Each objItem In mfInbox.Items
If TypeName(objItem) = strMailItem_c Then
Set miCurnt = objItem
If Not FolderExists(mfMain, miCurnt.SenderName) Then
Set mfDstn = mfMain.Folders.Add(miCurnt.SenderName)
Else
Set mfDstn = mfMain.Folders(miCurnt.SenderName)
End If
If copyOnly Then
miCurnt.Copy.Move mfDstn
Else
miCurnt.Move mfDstn
End If
End If
Next
Exit_Proc:
On Error Resume Next
Set objItem = Nothing
Set miCurnt = Nothing
Set mfInbox = Nothing
Set mfMain = Nothing
Set ns = Nothing
Exit Sub
Err_Hnd:
MsgBox Err.Description, vbSystemModal, "Error: " & Err.Number
Resume Exit_Proc
End Sub

Private Function FolderExists(ByRef parent As Outlook.MAPIFolder, _
ByVal name As String _
) As Boolean
On Error Resume Next
Dim mfTest As Outlook.MAPIFolder
Set mfTest = parent.Folders(name)
FolderExists = Not CBool(Err.Number)
End Function

[Marc Easy]

wow thanks, ill test it out t'nite!

[jgtg32a]

I have to do something similar to this.
I need to do the auto create and sort to folders what I'm searching by is in the subject. However its not the entire subject just part of it.
What I need is between '(' ')' that needs to be the folder name. I can kinda see how to do this I just found this example and else where I found an example using regex in VBA which I'm trying to modify to do the job.
Sub RegExpTest()
Dim re As RegExp
Dim strToSearch As String
Dim strPattern As String
Dim strResults As String
Dim oMatches As MatchCollection
Dim oMatch As Match

strToSearch = Selection.Text


Set re = New RegExp
re.Global = True
re.IgnoreCase = True

Do While (1)
strPattern = InputBox("Enter search pattern string:", "RegExp Search", "")
If Len(strPattern) = 0 Then Exit Do
re.Pattern = strPattern
Set oMatches = re.Execute(strToSearch)
If oMatches.Count <> 0 Then
strResults = Chr(34) & strPattern & Chr(34) & _
" matched " & oMatches.Count & " times:" _
& vbCr & vbCr
For Each oMatch In oMatches
strResults = strResults & _
oMatch.Value & _
": at position " & _
oMatch.FirstIndex & vbCr
Next oMatch
Else
strResults = Chr(34) & strPattern & Chr(34) & _
" didn't match anything. Try again."
End If
MsgBox strResults
Loop
End Sub


I think I got that from O'Reily

I'll post what I came up with soon

[jgtg32a]

Ok this is what I have ... it doesn't look that great I haven't done basic in years. One of the problems I'm having is it doesn't like my regex
"\((*)\)" that should say find '(' any number of characters then find ')' and it should set the pattern as the value of whats in between them.
Option Explicit
Public Sub Sorter()
'heavy copy, pasting by Mike Brown using code from vbaexpress . com/forum/showpost.php?p=142833&postcount=2
'Aaron Bush
'5-8-08 'Sean M. Burke, Andy Bruno, and Andrew Savikas from windowsdevcenter . com/pub/a/windows/excerpt/wdhks_1/index.html?page=4

Const strMailItem_c As String = "MailItem"
Dim ns As Outlook.NameSpace
Dim mfMain As Outlook.MAPIFolder
Dim mfInbox As Outlook.MAPIFolder
Dim mfDstn As Outlook.MAPIFolder
Dim miCurnt As Outlook.MailItem
Dim objItem As Object

Dim re As RegExp
Dim strToSearch As String
Dim strPattern As String
Dim strResults As String
Dim oMatches As MatchCollection
Dim oMatch As match

Dim found As match


Dim Pattern As String
Pattern = "a"
re.Pattern = Pattern 'look for this pattern
re.IgnoreCase = True 'don't care about case
re.Global = True

On Error GoTo Err_Hnd
Set ns = Outlook.Session
Set mfInbox = ns.GetDefaultFolder(olFolderInbox)
Set mfMain = mfInbox.parent

For Each objItem In mfInbox.Items
'regex stuff here
strToSearch = miCurnt.Forward
Set found = re.Execute(strToSearch) 'runs the regex on the forward address field

'end of regex stuff
If TypeName(objItem) = strMailItem_c Then
Set miCurnt = objItem
If Not FolderExists(mfMain, found) Then
Set mfDstn = mfMain.Folders.Add(found)
Else
Set mfDstn = mfMain.Folders(found)
End If
miCurnt.Copy.Move mfDstn
End If
Next
Exit_Proc:
On Error Resume Next
Set objItem = Nothing
Set miCurnt = Nothing
Set mfInbox = Nothing
Set mfMain = Nothing
Set ns = Nothing
Exit Sub
Err_Hnd:
MsgBox Err.Description, vbSystemModal, "Error: " & Err.Number
Resume Exit_Proc
End Sub

Private Function FolderExists(ByRef parent As Outlook.MAPIFolder, ByVal name As String) As Boolean
On Error Resume Next
Dim mfTest As Outlook.MAPIFolder
Set mfTest = parent.Folders(name)
FolderExists = Not CBool(Err.Number)
End Function