Hi all,

I have a macro that I use to organise certain email folders such as the spam
quarantine folder. Basically it looks at the date of an email and moves it
into a set of subfolders named by year then by month (and possibly by day,
depending on which option is selected on the form). But the problem is that
it is so slow that I am put off running it, as it ties up my Outlook for
hours, processing each individual item. For comparison, if I select a block
of around 3000 emails and drag them into a folder, it takes maybe 3 minutes
at most. To do the same 3000 emails with my macro takes an hour or more.

The code is below (and if anyone else finds it useful, feel free to copy
what you like, although I can't 100% guarantee it's all my work - I may have
nabbed snippets from various web sites):

Sub StartButton_Click()
On Error Resume Next

Dim ol As Outlook.Application
Set ol = Outlook.Application
Dim olns As Outlook.NameSpace
Set olns = ol.GetNamespace("MAPI")
Dim myExp As Explorer
Set myExp = ol.ActiveExplorer
Dim fldr As MAPIFolder
Set fldr = myExp.CurrentFolder
Dim dltd As MAPIFolder
Set dltd = olns.GetDefaultFolder(olFolderDeletedItems)
Dim yStr As String
Dim mStr As String
Dim dStr As String
yStr = ""
mStr = ""
dStr = ""
Dim myItems As Items
Set myItems = fldr.Items
Dim curItem As Outlook.MailItem
Dim mrItem As Outlook.MeetingItem
Dim repItem As Outlook.ReportItem
Dim tItem As Outlook.TaskItem
Dim itemTime As Date
Dim yFldr As MAPIFolder
Dim mFldr As MAPIFolder
Dim dFldr As MAPIFolder
itemCount = myItems.count
intUserAbort = 0

If (StatusBar.OptionMnth = True) Then GoTo SortMonthly

SortDaily:
' snip - it's pretty much the same as the sortmonthly code

SortMonthly:

For n = itemCount To 1 Step -1

DoEvents
If intUserAbort = 1 Then
MsgBox "User Aborted"
GoTo ExitSub
End If

If myItems(n).Class = olMail Then ' Only want emails
Set curItem = myItems(n)
ElseIf (53 myItems(n).Class 58) Then ' Meeting requests
Set mrItem = myItems(n)
mrItem.Move dltd
Set mrItem = Nothing
GoTo NextItem2
ElseIf myItems(n).Class = olReport Then ' Outlook Report items
Set repItem = myItems(n)
repItem.Move dltd
Set repItem = Nothing
GoTo NextItem2
ElseIf (47 myItems(n).Class 53) Then ' Outlook task items
Set tItem = myItems(n)
tItem.Move dltd
Set tItem = Nothing
GoTo NextItem2
Else
'MsgBox myItems(n).Class
GoTo NextItem2
End If

StatusBar.stNo = n
StatusBar.stTitle = curItem.Subject
itemTime = curItem.ReceivedTime
ItemYear = Year(itemTime)
ItemMnth = Month(itemTime)
ItemDay = Day(itemTime)
StatusBar.Repaint

' Check if the current item has the same date as the last one
' and if not then set and if neccesary create the folders.

If ((CStr(ItemYear) = yStr) And (CStr(ItemMnth) = mStr) And (CStr(ItemDay) =
dStr)) Then

GoTo MoveItem

Else
Set yFldr = Nothing
Set mFldr = Nothing
Set dFldr = Nothing

yStr = CStr(ItemYear)
mStr = CStr(ItemMnth)
dStr = CStr(ItemDay)

If Len(mStr) = 1 Then mStr = "0" + mStr
If Len(dStr) = 1 Then dStr = "0" + dStr

Set yFldr = fldr.Folders(yStr)
If Not yFldr Is Nothing Then
'
Else
fldr.Folders.Add (yStr)
Set yFldr = fldr.Folders(yStr)
End If

Set mFldr = yFldr.Folders(mStr)
If Not mFldr Is Nothing Then
'
Else
yFldr.Folders.Add (mStr)
Set mFldr = yFldr.Folders(mStr)
End If
End If

MoveItem:
curItem.Move mFldr
Set curItem = Nothing

NextItem2:

Next

StatusBar.CancelButton.Caption = "Close"
ExitSub:

End Sub

Thanks

Ralph

PS: I'm using Outlook XP if that makes a difference.

I suppose I should have mentioned, in case it wasn't obvious, that I'd really
appreciate any pointers toward getting the same functionality, but with the
speed of drag and drop. I only realised when I re-read my post that I hadn't
actually asked anything

Kind regards,

Ralph

You could speed up your code itself a little bit - but the slowest of all is
the loop through the Outlook object model. If you use CDO 1.21 or Redemption
(www.dimastr.com) it's a lot faster.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
Quick-Cats - Categorize Outlook data:
http://www.vboffice.net/product.html?id=2006063&cmd=detail&lang=en&pub=6

Am Fri, 25 May 2007 07:34:01 -0700 schrieb Ralph Pickering:

Hi all,

I have a macro that I use to organise certain email folders such as the
spam
quarantine folder. Basically it looks at the date of an email and moves it
into a set of subfolders named by year then by month (and possibly by day,
depending on which option is selected on the form). But the problem is
that
it is so slow that I am put off running it, as it ties up my Outlook for
hours, processing each individual item. For comparison, if I select a
block
of around 3000 emails and drag them into a folder, it takes maybe 3
minutes
at most. To do the same 3000 emails with my macro takes an hour or more.

The code is below (and if anyone else finds it useful, feel free to copy
what you like, although I can't 100% guarantee it's all my work - I may
have
nabbed snippets from various web sites):

Sub StartButton_Click()
On Error Resume Next

Dim ol As Outlook.Application
Set ol = Outlook.Application
Dim olns As Outlook.NameSpace
Set olns = ol.GetNamespace("MAPI")
Dim myExp As Explorer
Set myExp = ol.ActiveExplorer
Dim fldr As MAPIFolder
Set fldr = myExp.CurrentFolder
Dim dltd As MAPIFolder
Set dltd = olns.GetDefaultFolder(olFolderDeletedItems)
Dim yStr As String
Dim mStr As String
Dim dStr As String
yStr = ""
mStr = ""
dStr = ""
Dim myItems As Items
Set myItems = fldr.Items
Dim curItem As Outlook.MailItem
Dim mrItem As Outlook.MeetingItem
Dim repItem As Outlook.ReportItem
Dim tItem As Outlook.TaskItem
Dim itemTime As Date
Dim yFldr As MAPIFolder
Dim mFldr As MAPIFolder
Dim dFldr As MAPIFolder
itemCount = myItems.count
intUserAbort = 0

If (StatusBar.OptionMnth = True) Then GoTo SortMonthly

SortDaily:
' snip - it's pretty much the same as the sortmonthly code

SortMonthly:

For n = itemCount To 1 Step -1

DoEvents
If intUserAbort = 1 Then
MsgBox "User Aborted"
GoTo ExitSub
End If

If myItems(n).Class = olMail Then ' Only want emails
Set curItem = myItems(n)
ElseIf (53 myItems(n).Class 58) Then ' Meeting requests
Set mrItem = myItems(n)
mrItem.Move dltd
Set mrItem = Nothing
GoTo NextItem2
ElseIf myItems(n).Class = olReport Then ' Outlook Report items
Set repItem = myItems(n)
repItem.Move dltd
Set repItem = Nothing
GoTo NextItem2
ElseIf (47 myItems(n).Class 53) Then ' Outlook task items
Set tItem = myItems(n)
tItem.Move dltd
Set tItem = Nothing
GoTo NextItem2
Else
'MsgBox myItems(n).Class
GoTo NextItem2
End If

StatusBar.stNo = n
StatusBar.stTitle = curItem.Subject
itemTime = curItem.ReceivedTime
ItemYear = Year(itemTime)
ItemMnth = Month(itemTime)
ItemDay = Day(itemTime)
StatusBar.Repaint

' Check if the current item has the same date as the last one
' and if not then set and if neccesary create the folders.

If ((CStr(ItemYear) = yStr) And (CStr(ItemMnth) = mStr) And (CStr(ItemDay)
=
dStr)) Then

GoTo MoveItem

Else
Set yFldr = Nothing
Set mFldr = Nothing
Set dFldr = Nothing

yStr = CStr(ItemYear)
mStr = CStr(ItemMnth)
dStr = CStr(ItemDay)

If Len(mStr) = 1 Then mStr = "0" + mStr
If Len(dStr) = 1 Then dStr = "0" + dStr

Set yFldr = fldr.Folders(yStr)
If Not yFldr Is Nothing Then
'
Else
fldr.Folders.Add (yStr)
Set yFldr = fldr.Folders(yStr)
End If

Set mFldr = yFldr.Folders(mStr)
If Not mFldr Is Nothing Then
'
Else
yFldr.Folders.Add (mStr)
Set mFldr = yFldr.Folders(mStr)
End If
End If

MoveItem:
curItem.Move mFldr
Set curItem = Nothing

NextItem2:

Next

StatusBar.CancelButton.Caption = "Close"
ExitSub:

End Sub

Thanks

Ralph

PS: I'm using Outlook XP if that makes a difference.

I've done some bits with Redemption in the past, so I'll give that a whirl.
Thanks for the feedback.