fireguy1125
asked on
Outlook Macro to Move Email to PST Files
I am in the process of moving emails from a mailbox into PST files, however am only limited to do this a few hundred email messages at a time manually, otherwise I receive an error. I found an article where a VB Macro was created to automate this process and prevent the error:
http://blogs.msdn.com/b/robert_mcmurray/archive/2010/02/25/outlook-macros-part-1-moving-emails-into-personal-folders.aspx
I am performing a similar method, however I need the macro to contain a date range smaller than a year. In my case, I need to be able to put in a range of months within a year into the following PST files such as:
Inbox Date range --- Folder name
1/1/2012 - 3/31/2012 --- 2012 Q1
4/1/2012 - 6/30/2012 --- 2012 Q2
7/1/2012 - 9/30/2012 --- 2012 Q3
10/1/2012 - 12/31/2012 --- 2012 Q4
Sent items Date range --- Folder name
1/1/2012-6/30/2012 --- 2012 Sent Q1Q2
7/1/2012-12/31/2012 --- 2012 Sent Q3Q4
I need it to run through the inbox and sent folders.
I don't have any knowledge of scripting or programming myself, but if you can please enter comments as to where I would modify the date range and folder name, I can take care of the rest.
Thanks so much in advance.
http://blogs.msdn.com/b/robert_mcmurray/archive/2010/02/25/outlook-macros-part-1-moving-emails-into-personal-folders.aspx
I am performing a similar method, however I need the macro to contain a date range smaller than a year. In my case, I need to be able to put in a range of months within a year into the following PST files such as:
Inbox Date range --- Folder name
1/1/2012 - 3/31/2012 --- 2012 Q1
4/1/2012 - 6/30/2012 --- 2012 Q2
7/1/2012 - 9/30/2012 --- 2012 Q3
10/1/2012 - 12/31/2012 --- 2012 Q4
Sent items Date range --- Folder name
1/1/2012-6/30/2012 --- 2012 Sent Q1Q2
7/1/2012-12/31/2012 --- 2012 Sent Q3Q4
I need it to run through the inbox and sent folders.
I don't have any knowledge of scripting or programming myself, but if you can please enter comments as to where I would modify the date range and folder name, I can take care of the rest.
Thanks so much in advance.
I've modified the routine based upon your request. It will work to move items from your Inbox. We'll need to tweak it a bit for Sent Items. Do you know how to enter this into the VBE in Outlook?
OM Gang
Sub MoveOldEmails()
On Error GoTo Err_MoveOldEmails
' Declare all variables.
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedMailItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String, strArchiveFolder
' set the display name for the archive folder you want to move messages to
strArchiveFolder = "Personal Folders - My Archive"
' Create an object for the Outlook application.
Set objOutlook = Application
' Retrieve an object for the MAPI namespace.
Set objNamespace = objOutlook.GetNamespace("M
' Retrieve a folder object for the source folder.
Set objSourceFolder = objNamespace.GetDefaultFol
' Loop through the items in the folder. NOTE: This has to
' be done backwards; if you process forwards you have to
' re-run the macro an inverse exponential number of times.
For intCount = objSourceFolder.Items.Coun
' Retrieve an object from the folder.
Set objVariant = objSourceFolder.Items.Item
' Allow the system to process. (Helps you to cancel the
' macro, or continue to use Outlook in the background.)
DoEvents
' Filter objects for emails or meeting requests.
If objVariant.Class = olMail Or objVariant.Class = olMeetingRequest Then
' This is optional, but it helps me to see in the
' debug window where the macro is currently at.
Debug.Print objVariant.SentOn
' Calculate the difference in years between
' this year and the year of the mail object.
'intDateDiff = DateDiff("yyyy", objVariant.SentOn, Now)
' Only process the object if it isn't this year.
'If intDateDiff > 0 Then
' only specify a destination folder if the date range matches
Select Case objVariant.SentOn
Case #1/1/2012# To #3/31/2012#
strDestFolder = "2012 Q1"
Case #4/1/2012# To #6/30/2012#
strDestFolder = "2012 Q2"
Case #7/1/2012# To #9/30/2012#
strDestFolder = "2012 Q3"
Case #10/1/2012# To #12/31/2012#
strDestFolder = "2012 Q4"
Case Else
strDestFolder = ""
End Select
' Calculate the name of the personal folder.
'strDestFolder = "Personal Folders (" & _
'Year(objVariant.SentOn) & ")"
' only move the item if the destination folder variable is a non zero length string
If strDestFolder <> "" Then
' Retrieve a folder object for the destination folder.
'Set objDestFolder = objNamespace.Folders(strDe
Set objDestFolder = objNamespace.Folders(strAr
' Move the object to the destination folder.
objVariant.Move objDestFolder
' Just for curiousity, I like to see the number
' of items that were moved when the macro completes.
lngMovedMailItems = lngMovedMailItems + 1
' Destroy the destination folder object.
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedMailItems & " messages(s)."
Exit_MoveOldEmails:
'destroy object variables
Set objVariant = Nothing
Set objSourceFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
Exit Sub
Err_MoveOldEmails:
MsgBox Err.Number & " (" & Err.Description & ") in procedure MoveOldEmails of Module Module3"
Resume Exit_MoveOldEmails
End Sub
OM Gang
Sub MoveOldEmails()
On Error GoTo Err_MoveOldEmails
' Declare all variables.
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedMailItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String, strArchiveFolder
' set the display name for the archive folder you want to move messages to
strArchiveFolder = "Personal Folders - My Archive"
' Create an object for the Outlook application.
Set objOutlook = Application
' Retrieve an object for the MAPI namespace.
Set objNamespace = objOutlook.GetNamespace("M
' Retrieve a folder object for the source folder.
Set objSourceFolder = objNamespace.GetDefaultFol
' Loop through the items in the folder. NOTE: This has to
' be done backwards; if you process forwards you have to
' re-run the macro an inverse exponential number of times.
For intCount = objSourceFolder.Items.Coun
' Retrieve an object from the folder.
Set objVariant = objSourceFolder.Items.Item
' Allow the system to process. (Helps you to cancel the
' macro, or continue to use Outlook in the background.)
DoEvents
' Filter objects for emails or meeting requests.
If objVariant.Class = olMail Or objVariant.Class = olMeetingRequest Then
' This is optional, but it helps me to see in the
' debug window where the macro is currently at.
Debug.Print objVariant.SentOn
' Calculate the difference in years between
' this year and the year of the mail object.
'intDateDiff = DateDiff("yyyy", objVariant.SentOn, Now)
' Only process the object if it isn't this year.
'If intDateDiff > 0 Then
' only specify a destination folder if the date range matches
Select Case objVariant.SentOn
Case #1/1/2012# To #3/31/2012#
strDestFolder = "2012 Q1"
Case #4/1/2012# To #6/30/2012#
strDestFolder = "2012 Q2"
Case #7/1/2012# To #9/30/2012#
strDestFolder = "2012 Q3"
Case #10/1/2012# To #12/31/2012#
strDestFolder = "2012 Q4"
Case Else
strDestFolder = ""
End Select
' Calculate the name of the personal folder.
'strDestFolder = "Personal Folders (" & _
'Year(objVariant.SentOn) & ")"
' only move the item if the destination folder variable is a non zero length string
If strDestFolder <> "" Then
' Retrieve a folder object for the destination folder.
'Set objDestFolder = objNamespace.Folders(strDe
Set objDestFolder = objNamespace.Folders(strAr
' Move the object to the destination folder.
objVariant.Move objDestFolder
' Just for curiousity, I like to see the number
' of items that were moved when the macro completes.
lngMovedMailItems = lngMovedMailItems + 1
' Destroy the destination folder object.
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedMailItems & " messages(s)."
Exit_MoveOldEmails:
'destroy object variables
Set objVariant = Nothing
Set objSourceFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
Exit Sub
Err_MoveOldEmails:
MsgBox Err.Number & " (" & Err.Description & ") in procedure MoveOldEmails of Module Module3"
Resume Exit_MoveOldEmails
End Sub
Sorry, declaration should have been specific
Dim strDestFolder As String, strArchiveFolder As String
It will work as I had it before though.
OM Gang
Dim strDestFolder As String, strArchiveFolder As String
It will work as I had it before though.
OM Gang
Give this a shot and let me know if you have any problems. It will prompt to archive either Inbox or Sent Items. You need to change the value of strArchiveFolder to whatever the display name of your actual archive folder is.
OM Gang
Sub MoveOldEmails()
On Error GoTo Err_MoveOldEmails
' Declare all variables.
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedMailItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer, intResponse As Integer
Dim strDestFolder As String, strArchiveFolder As String
' set the display name for the archive folder you want to move messages to
'strArchiveFolder = "Personal Folders - My Archive"
strArchiveFolder = "Archive Folders"
' Create an object for the Outlook application.
Set objOutlook = Application
' Retrieve an object for the MAPI namespace.
Set objNamespace = objOutlook.GetNamespace("M
' Retrieve a folder object for the source folder.
'Set objSourceFolder = objNamespace.GetDefaultFol
' prompt to archive Inbox or Sent Items
intResponse = MsgBox("Archive Inbox?", vbYesNoCancel, "Select Folder to Archive")
Select Case intResponse
Case vbYes
Set objSourceFolder = objNamespace.GetDefaultFol
Case vbCancel
GoTo Exit_MoveOldEmails
Case Else
'includes case when user clicks No at prompt
End Select
If objSourceFolder Is Nothing Then
intResponse = MsgBox("Archive Sent Items?", vbYesNo, "Select Folder to Archive")
If intResponse = vbYes Then
Set objSourceFolder = objNamespace.GetDefaultFol
Else
'user chose No at second message box
GoTo Exit_MoveOldEmails
End If
End If
' Loop through the items in the folder. NOTE: This has to
' be done backwards; if you process forwards you have to
' re-run the macro an inverse exponential number of times.
For intCount = objSourceFolder.Items.Coun
' Retrieve an object from the folder.
Set objVariant = objSourceFolder.Items.Item
' Allow the system to process. (Helps you to cancel the
' macro, or continue to use Outlook in the background.)
DoEvents
' Filter objects for emails or meeting requests.
If objVariant.Class = olMail Or objVariant.Class = olMeetingRequest Then
' This is optional, but it helps me to see in the
' debug window where the macro is currently at.
Debug.Print objVariant.SentOn
' Calculate the difference in years between
' this year and the year of the mail object.
'intDateDiff = DateDiff("yyyy", objVariant.SentOn, Now)
' Only process the object if it isn't this year.
'If intDateDiff > 0 Then
' only specify a destination folder if the date range matches
Select Case objSourceFolder.Name
Case "Inbox"
Select Case objVariant.SentOn
Case #1/1/2012# To #3/31/2012#
strDestFolder = "2012 Q1"
Case #4/1/2012# To #6/30/2012#
strDestFolder = "2012 Q2"
Case #7/1/2012# To #9/30/2012#
strDestFolder = "2012 Q3"
Case #10/1/2012# To #12/31/2012#
strDestFolder = "2012 Q4"
Case Else
strDestFolder = ""
End Select
Case "Sent Items"
Select Case objVariant.SentOn
Case #1/1/2012# To #6/30/2012#
strDestFolder = "2012 Sent Q1Q2"
Case #7/1/2012# To #12/31/2012#
strDestFolder = "2012 Sent Q3Q4"
Case Else
strDestFolder = ""
End Select
End Select
' Calculate the name of the personal folder.
'strDestFolder = "Personal Folders (" & _
'Year(objVariant.SentOn) & ")"
' only move the item if the destination folder variable is a non zero length string
If strDestFolder <> "" Then
' Retrieve a folder object for the destination folder.
'Set objDestFolder = objNamespace.Folders(strDe
Set objDestFolder = objNamespace.Folders(strAr
' Move the object to the destination folder.
objVariant.Move objDestFolder
' Just for curiousity, I like to see the number
' of items that were moved when the macro completes.
lngMovedMailItems = lngMovedMailItems + 1
' Destroy the destination folder object.
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedMailItems & " messages(s)."
Exit_MoveOldEmails:
'destroy object variables
Set objVariant = Nothing
Set objSourceFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
Exit Sub
Err_MoveOldEmails:
MsgBox Err.Number & " (" & Err.Description & ") in procedure MoveOldEmails of Module Module3"
Resume Exit_MoveOldEmails
End Sub
OM Gang
Sub MoveOldEmails()
On Error GoTo Err_MoveOldEmails
' Declare all variables.
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedMailItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer, intResponse As Integer
Dim strDestFolder As String, strArchiveFolder As String
' set the display name for the archive folder you want to move messages to
'strArchiveFolder = "Personal Folders - My Archive"
strArchiveFolder = "Archive Folders"
' Create an object for the Outlook application.
Set objOutlook = Application
' Retrieve an object for the MAPI namespace.
Set objNamespace = objOutlook.GetNamespace("M
' Retrieve a folder object for the source folder.
'Set objSourceFolder = objNamespace.GetDefaultFol
' prompt to archive Inbox or Sent Items
intResponse = MsgBox("Archive Inbox?", vbYesNoCancel, "Select Folder to Archive")
Select Case intResponse
Case vbYes
Set objSourceFolder = objNamespace.GetDefaultFol
Case vbCancel
GoTo Exit_MoveOldEmails
Case Else
'includes case when user clicks No at prompt
End Select
If objSourceFolder Is Nothing Then
intResponse = MsgBox("Archive Sent Items?", vbYesNo, "Select Folder to Archive")
If intResponse = vbYes Then
Set objSourceFolder = objNamespace.GetDefaultFol
Else
'user chose No at second message box
GoTo Exit_MoveOldEmails
End If
End If
' Loop through the items in the folder. NOTE: This has to
' be done backwards; if you process forwards you have to
' re-run the macro an inverse exponential number of times.
For intCount = objSourceFolder.Items.Coun
' Retrieve an object from the folder.
Set objVariant = objSourceFolder.Items.Item
' Allow the system to process. (Helps you to cancel the
' macro, or continue to use Outlook in the background.)
DoEvents
' Filter objects for emails or meeting requests.
If objVariant.Class = olMail Or objVariant.Class = olMeetingRequest Then
' This is optional, but it helps me to see in the
' debug window where the macro is currently at.
Debug.Print objVariant.SentOn
' Calculate the difference in years between
' this year and the year of the mail object.
'intDateDiff = DateDiff("yyyy", objVariant.SentOn, Now)
' Only process the object if it isn't this year.
'If intDateDiff > 0 Then
' only specify a destination folder if the date range matches
Select Case objSourceFolder.Name
Case "Inbox"
Select Case objVariant.SentOn
Case #1/1/2012# To #3/31/2012#
strDestFolder = "2012 Q1"
Case #4/1/2012# To #6/30/2012#
strDestFolder = "2012 Q2"
Case #7/1/2012# To #9/30/2012#
strDestFolder = "2012 Q3"
Case #10/1/2012# To #12/31/2012#
strDestFolder = "2012 Q4"
Case Else
strDestFolder = ""
End Select
Case "Sent Items"
Select Case objVariant.SentOn
Case #1/1/2012# To #6/30/2012#
strDestFolder = "2012 Sent Q1Q2"
Case #7/1/2012# To #12/31/2012#
strDestFolder = "2012 Sent Q3Q4"
Case Else
strDestFolder = ""
End Select
End Select
' Calculate the name of the personal folder.
'strDestFolder = "Personal Folders (" & _
'Year(objVariant.SentOn) & ")"
' only move the item if the destination folder variable is a non zero length string
If strDestFolder <> "" Then
' Retrieve a folder object for the destination folder.
'Set objDestFolder = objNamespace.Folders(strDe
Set objDestFolder = objNamespace.Folders(strAr
' Move the object to the destination folder.
objVariant.Move objDestFolder
' Just for curiousity, I like to see the number
' of items that were moved when the macro completes.
lngMovedMailItems = lngMovedMailItems + 1
' Destroy the destination folder object.
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedMailItems & " messages(s)."
Exit_MoveOldEmails:
'destroy object variables
Set objVariant = Nothing
Set objSourceFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
Exit Sub
Err_MoveOldEmails:
MsgBox Err.Number & " (" & Err.Description & ") in procedure MoveOldEmails of Module Module3"
Resume Exit_MoveOldEmails
End Sub
ASKER
Thank you omgang,
I should have been more clear in my original request, however the strDestFolder with the 2012 Q1, Q2, Q3, Q4, are actually supposed to be separate Archive folders, and not subfolders within a single archive folder.
There are a total of 6 Archive Folders. 4 of the Archive folders have an Inbox subfolder. 2 of the Archive folders have Sent Items sub folders.
So the instructions would be to:
1. Move Mail items from Outlook Inbox dated 1/1/2012 - 3/31/2012 to archive folder '2012 Q1' within subfolder 'Inbox'
2. Move Mail items from Outlook Inbox dated 4/1/2012 - 6/30/2012 to archive folder '2012 Q2' subfolder 'Inbox'
3. Move Mail items from Outlook Inbox dated 7/1/2012 - 9/30/2012 to archive folder '2012 Q3' subfolder 'Inbox'
4. Move Mail items from Outlook Inbox dated 10/1/2012 - 12/31/2012 to archive folder '2012 Q4' subfolder 'Inbox'
5. Move Mail items from Outlook Sent Items dated 1/1/2012-6/30/2012 to archive folder '2012 Sent Q1Q2' subfolder 'Sent Items'
6. Move Mail items from Outlook Inbox dated 7/1/2012-12/31/2012 to archive folder '2012 Sent Q3Q4' subfolder 'Sent Items'
I hope this makes this clear, my apologies for not detailing this earlier.
Thank you.
I should have been more clear in my original request, however the strDestFolder with the 2012 Q1, Q2, Q3, Q4, are actually supposed to be separate Archive folders, and not subfolders within a single archive folder.
There are a total of 6 Archive Folders. 4 of the Archive folders have an Inbox subfolder. 2 of the Archive folders have Sent Items sub folders.
So the instructions would be to:
1. Move Mail items from Outlook Inbox dated 1/1/2012 - 3/31/2012 to archive folder '2012 Q1' within subfolder 'Inbox'
2. Move Mail items from Outlook Inbox dated 4/1/2012 - 6/30/2012 to archive folder '2012 Q2' subfolder 'Inbox'
3. Move Mail items from Outlook Inbox dated 7/1/2012 - 9/30/2012 to archive folder '2012 Q3' subfolder 'Inbox'
4. Move Mail items from Outlook Inbox dated 10/1/2012 - 12/31/2012 to archive folder '2012 Q4' subfolder 'Inbox'
5. Move Mail items from Outlook Sent Items dated 1/1/2012-6/30/2012 to archive folder '2012 Sent Q1Q2' subfolder 'Sent Items'
6. Move Mail items from Outlook Inbox dated 7/1/2012-12/31/2012 to archive folder '2012 Sent Q3Q4' subfolder 'Sent Items'
I hope this makes this clear, my apologies for not detailing this earlier.
Thank you.
ASKER
Please see the attached image to show you, I would not want mail items directly in the Archive Folders, but rather in the Inbox and Sent items sub folders respectively.
OK. I'll make changes.
OM Gang
OM Gang
Pretty minor changes. I removed a bunch of commented/unused code lines though to clean it up.
OM Gang
Sub MoveOldEmails()
On Error GoTo Err_MoveOldEmails
' Declare all variables.
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedMailItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer, intResponse As Integer
Dim strDestFolder As String, strArchiveFolder As String
' Create an object for the Outlook application.
Set objOutlook = Application
' Retrieve an object for the MAPI namespace.
Set objNamespace = objOutlook.GetNamespace("M
' prompt to archive Inbox or Sent Items
intResponse = MsgBox("Archive Inbox?", vbYesNoCancel, "Select Folder to Archive")
Select Case intResponse
Case vbYes
Set objSourceFolder = objNamespace.GetDefaultFol
Case vbCancel
GoTo Exit_MoveOldEmails
Case Else
'includes case when user clicks No at prompt
End Select
If objSourceFolder Is Nothing Then
intResponse = MsgBox("Archive Sent Items?", vbYesNo, "Select Folder to Archive")
If intResponse = vbYes Then
Set objSourceFolder = objNamespace.GetDefaultFol
Else
'user chose No at second message box
GoTo Exit_MoveOldEmails
End If
End If
' Loop through the items in the folder. NOTE: This has to
' be done backwards; if you process forwards you have to
' re-run the macro an inverse exponential number of times.
For intCount = objSourceFolder.Items.Coun
' Retrieve an object from the folder.
Set objVariant = objSourceFolder.Items.Item
' Allow the system to process. (Helps you to cancel the
' macro, or continue to use Outlook in the background.)
DoEvents
' Filter objects for emails or meeting requests.
If objVariant.Class = olMail Or objVariant.Class = olMeetingRequest Then
' This is optional, but it helps me to see in the
' debug window where the macro is currently at.
Debug.Print objVariant.SentOn
' only specify a destination folder if the date range matches
Select Case objSourceFolder.Name
Case "Inbox"
Select Case objVariant.SentOn
Case #1/1/2012# To #3/31/2012#
strArchiveFolder = "2012 Q1"
strDestFolder = "Inbox"
Case #4/1/2012# To #6/30/2012#
strArchiveFolder = "2012 Q2"
strDestFolder = "Inbox"
Case #7/1/2012# To #9/30/2012#
strArchiveFolder = "2012 Q3"
strDestFolder = "Inbox"
Case #10/1/2012# To #12/31/2012#
strArchiveFolder = "2012 Q4"
strDestFolder = "Inbox"
Case Else
strArchiveFolder = ""
strDestFolder = ""
End Select
Case "Sent Items"
Select Case objVariant.SentOn
Case #1/1/2012# To #6/30/2012#
strArchiveFolder = "2012 Sent Q1Q2"
strDestFolder = "Sent Items"
Case #7/1/2012# To #12/31/2012#
strArchiveFolder = "2012 Sent Q3Q4"
strDestFolder = "Sent Items"
Case Else
strArchiveFolder = ""
strDestFolder = ""
End Select
End Select
' only move the item if the destination folder variable is a non zero length string
If strArchiveFolder <> "" Then
' Retrieve a folder object for the destination folder.
Set objDestFolder = objNamespace.Folders(strAr
' Move the object to the destination folder.
objVariant.Move objDestFolder
' Just for curiousity, I like to see the number
' of items that were moved when the macro completes.
lngMovedMailItems = lngMovedMailItems + 1
' Destroy the destination folder object.
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedMailItems & " messages(s)."
Exit_MoveOldEmails:
'destroy object variables
Set objVariant = Nothing
Set objSourceFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
Exit Sub
Err_MoveOldEmails:
MsgBox Err.Number & " (" & Err.Description & ") in procedure MoveOldEmails of Module Module3"
Resume Exit_MoveOldEmails
End Sub
OM Gang
Sub MoveOldEmails()
On Error GoTo Err_MoveOldEmails
' Declare all variables.
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedMailItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer, intResponse As Integer
Dim strDestFolder As String, strArchiveFolder As String
' Create an object for the Outlook application.
Set objOutlook = Application
' Retrieve an object for the MAPI namespace.
Set objNamespace = objOutlook.GetNamespace("M
' prompt to archive Inbox or Sent Items
intResponse = MsgBox("Archive Inbox?", vbYesNoCancel, "Select Folder to Archive")
Select Case intResponse
Case vbYes
Set objSourceFolder = objNamespace.GetDefaultFol
Case vbCancel
GoTo Exit_MoveOldEmails
Case Else
'includes case when user clicks No at prompt
End Select
If objSourceFolder Is Nothing Then
intResponse = MsgBox("Archive Sent Items?", vbYesNo, "Select Folder to Archive")
If intResponse = vbYes Then
Set objSourceFolder = objNamespace.GetDefaultFol
Else
'user chose No at second message box
GoTo Exit_MoveOldEmails
End If
End If
' Loop through the items in the folder. NOTE: This has to
' be done backwards; if you process forwards you have to
' re-run the macro an inverse exponential number of times.
For intCount = objSourceFolder.Items.Coun
' Retrieve an object from the folder.
Set objVariant = objSourceFolder.Items.Item
' Allow the system to process. (Helps you to cancel the
' macro, or continue to use Outlook in the background.)
DoEvents
' Filter objects for emails or meeting requests.
If objVariant.Class = olMail Or objVariant.Class = olMeetingRequest Then
' This is optional, but it helps me to see in the
' debug window where the macro is currently at.
Debug.Print objVariant.SentOn
' only specify a destination folder if the date range matches
Select Case objSourceFolder.Name
Case "Inbox"
Select Case objVariant.SentOn
Case #1/1/2012# To #3/31/2012#
strArchiveFolder = "2012 Q1"
strDestFolder = "Inbox"
Case #4/1/2012# To #6/30/2012#
strArchiveFolder = "2012 Q2"
strDestFolder = "Inbox"
Case #7/1/2012# To #9/30/2012#
strArchiveFolder = "2012 Q3"
strDestFolder = "Inbox"
Case #10/1/2012# To #12/31/2012#
strArchiveFolder = "2012 Q4"
strDestFolder = "Inbox"
Case Else
strArchiveFolder = ""
strDestFolder = ""
End Select
Case "Sent Items"
Select Case objVariant.SentOn
Case #1/1/2012# To #6/30/2012#
strArchiveFolder = "2012 Sent Q1Q2"
strDestFolder = "Sent Items"
Case #7/1/2012# To #12/31/2012#
strArchiveFolder = "2012 Sent Q3Q4"
strDestFolder = "Sent Items"
Case Else
strArchiveFolder = ""
strDestFolder = ""
End Select
End Select
' only move the item if the destination folder variable is a non zero length string
If strArchiveFolder <> "" Then
' Retrieve a folder object for the destination folder.
Set objDestFolder = objNamespace.Folders(strAr
' Move the object to the destination folder.
objVariant.Move objDestFolder
' Just for curiousity, I like to see the number
' of items that were moved when the macro completes.
lngMovedMailItems = lngMovedMailItems + 1
' Destroy the destination folder object.
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedMailItems & " messages(s)."
Exit_MoveOldEmails:
'destroy object variables
Set objVariant = Nothing
Set objSourceFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
Exit Sub
Err_MoveOldEmails:
MsgBox Err.Number & " (" & Err.Description & ") in procedure MoveOldEmails of Module Module3"
Resume Exit_MoveOldEmails
End Sub
ASKER
Hi OM Gang,
Thank you for the updated code. Sorry it took so long to get back to you, as I'm only able to work on this after 9PM EST.
When I copied and pasted the code into Visual Basic in Outlook and ran it, it prompted me if I would like to Archive Inbox? - I select Yes.
The next pop-up that immediately appears says:
6 (Overflow) in procedure MoveOldEmails of Module Module3
When i run Debug, and step into, it seems to get stuck at Ln 48:
For intCount = objSourceFolder.Items.Coun
before jumping to line 135:
MsgBox Err.Number & " (" & Err.Description & ") in procedure MoveOldEmails of Module Module3"
Thank you for the updated code. Sorry it took so long to get back to you, as I'm only able to work on this after 9PM EST.
When I copied and pasted the code into Visual Basic in Outlook and ran it, it prompted me if I would like to Archive Inbox? - I select Yes.
The next pop-up that immediately appears says:
6 (Overflow) in procedure MoveOldEmails of Module Module3
When i run Debug, and step into, it seems to get stuck at Ln 48:
For intCount = objSourceFolder.Items.Coun
before jumping to line 135:
MsgBox Err.Number & " (" & Err.Description & ") in procedure MoveOldEmails of Module Module3"
That loop is part of the original code from the link you provided. It counts backwards from the total item count. How many messages are in your Inbox? My first guess is you have over 32,767 items which would exceed the max value for an integer data-type variable (intCount is declared as an Integer). A simple test is to change the declaration from Integer to Long. You won't need to change anything else.
Dim intCount As Long
OM Gang
Dim intCount As Long
OM Gang
ASKER
There are over 350,000 messages in the Inbox.
Also, I should mention since this will be a very time consuming process due to the number of messages and size of some of the messages being a few MB, and I really only have 10 hours to allow this to run at any time (9PM to 7AM), will this VB code let me cancel the process manually, and continue where it left off the next time it is run?
Thanks again
Also, I should mention since this will be a very time consuming process due to the number of messages and size of some of the messages being a few MB, and I really only have 10 hours to allow this to run at any time (9PM to 7AM), will this VB code let me cancel the process manually, and continue where it left off the next time it is run?
Thanks again
350,000! Oh my gosh. I give users a bad time when they get over a few thousand in their Inbox. Anyway....
To stop a macro/routine while processing you can key in Ctrl+Break. Be advised that this will stop the routine ungracefully and not allow object variables to be destroyed and could result in a lost message (if it was in the process of being moved).
If it were me I'd process in batches either by a fixed number, e.g. 10,000 at a time or for a given date range, e.g. only process messages with a SentOn date between 1/1/2012 & 1/31/2012. See how long it takes to do one month and then decide if I wanted to do two months the next time.
We can modify the routine easily enough to accept date range parameters or a loop count parameter.
OM Gang
To stop a macro/routine while processing you can key in Ctrl+Break. Be advised that this will stop the routine ungracefully and not allow object variables to be destroyed and could result in a lost message (if it was in the process of being moved).
If it were me I'd process in batches either by a fixed number, e.g. 10,000 at a time or for a given date range, e.g. only process messages with a SentOn date between 1/1/2012 & 1/31/2012. See how long it takes to do one month and then decide if I wanted to do two months the next time.
We can modify the routine easily enough to accept date range parameters or a loop count parameter.
OM Gang
ASKER
Ok, let's modify so it does only 1 range per run Instead of all 6 date ranges. I will then change the dates once it completes. If you can produce one for inbox and a separate one for sent that will probably be best.
Thanks again
Thanks again
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thanks so much for all your help!
OM Gang