R
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 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.