![]() |
If this is your first visit, be sure to check out the FAQ by clicking the link above. You may have to register before you can post: click the register link above to proceed. To start viewing messages, select the forum that you want to visit from the selection below. |
|
|
Thread Tools | Search this Thread | Display Modes |
#1
|
|||
|
|||
![]()
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. |
Ads |
#2
|
|||
|
|||
![]()
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 |
#3
|
|||
|
|||
![]() 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. |
#4
|
|||
|
|||
![]()
I've done some bits with Redemption in the past, so I'll give that a whirl.
Thanks for the feedback. |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
create a macro to move outlook 2003 message to a specific fold | robin | Outlook and VBA | 0 | May 4th 07 12:09 PM |
Macro to move a cell to centre screen | Victor Delta | Outlook and VBA | 2 | February 21st 07 09:54 PM |
Speeding up my code | Tinz | Outlook and VBA | 1 | June 30th 06 05:00 PM |
Macro to Move Mail Messages from Draft folder to other folders | VBnovice | Outlook and VBA | 4 | June 14th 06 08:10 PM |
Speeding up faxing of image attachments | Scott | Outlook - Fax Functions | 1 | February 18th 06 01:09 PM |