RE: How to move Outlook items to pst folders via VBA

[yooneek]

(This is a response to thread605-1547504)

Since this thread was already closed, and it took me several hours to accomplish my goal. I felt the need to share my work with others.

I do not claim any fame with this, I'm just borrowing from others work that I've managed to manipulate to my needs. There are probably an easier method, but I was unable to find it on Google.

There are two parts: 1) Function to translate the Outlook Folder path name; 2) A Sub that allows you to set which pst folders to move emails to.

In my case, I wanted to transfer all of my sent mails from the Exchanger Server account to a pst named "Sent Items 010108-", with a folder named Sent Items. Then copy all of the Drafts from the Server to my Personal Folders\Drafts folder. And finally, delete all of the Deleted Items on the Server.

Go to Outlook VBA, copy and paste (edit file locations as neccessary)

===================================================
'Sue Mosher
'

http://www.outlookcode.com/d/code/getfolder.htm

'DO NOT MODIFY THIS FUNCTION

Public Function GetFolder(strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function

------------------------------

'Eric Legault
'

http://www.tech-archive.net/Archive...lic.outlook.program_vba/2006-07/msg00066.html

'EDIT FOLDER LOCATIONS HERE
'
Sub CleanOutlook()
On Error Resume Next

'Moves Sent Items
Set objDestinationFolder = GetFolder("Sent Items 010108-\Sent Items")

Set objSourceItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail).Items

For Each objSourceItem In objSourceItems
objSourceItem.Move objDestinationFolder
Next

'Moves Drafts
Set objDestinationFolder = GetFolder("Personal Folders\Drafts")

Set objSourceItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts).Items

For Each objSourceItem In objSourceItems
objSourceItem.Move objDestinationFolder
Next

For Each objSourceItem In Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems).Items
objSourceItem.Delete
Next

End Sub

 

[yooneek]

Since posting this, I have upgraded to Outlook 2007 and run into several issues, which have led to some design changes and improvements... It now runs faster



Sub CleanOutlook()

Dim objNS As Variant
Dim objSourceItems As Items
Dim objSourceItem As MailItem
Dim objDestinationFolder As Folder
Dim IC As Integer


On Error Resume Next

Set objNS = Application.GetNamespace("MAPI")

'Moves Sent Items
Set objDestinationFolder = GetFolder("Sent Items 010108-\Sent Items")
Set objSourceItems = objNS.GetDefaultFolder(olFolderSentMail).Items

IC = objSourceItems.Count()
For I = IC To 1 Step -1
objSourceItems(I).Move objDestinationFolder
Next I


'Move Read Items from Server to Folder
Set objDestinationFolder = GetFolder("Personal Folders\Inbox")
Set objSourceItems = objNS.GetDefaultFolder(olFolderInbox).Items.Restrict("[Unread] = False")

IC = objSourceItems.Count()
For I = IC To 1 Step -1
If objSourceItems.Items(I).UnRead = False Then
objSourceItems(I).Move objDestinationFolder
End If
Next I


'Moves Drafts
'Set objDestinationFolder = GetFolder("Personal Folders\Drafts")
'Set objSourceItems = objNS.GetDefaultFolder(olFolderDrafts).Items

'IC = objSourceItems.Count()
'For I = IC To 1 Step -1
' objSourceItems(I).Move objDestinationFolder
'Next I


'Delete read items in OtherFolder [Note: When looking for unread mail using GetFolder, have to use If/Then, not Restrict]
Set objDestinationFolder = GetFolder("Personal Folders\OtherFolder")

IC = objDestinationFolder.Items.Count()
For I = IC To 1 Step -1
If objDestinationFolder.Items(I).UnRead = False Then
objDestinationFolder.Items(I).Delete
End If
Next I


'Delete Deleted Items
Set objDestinationFolder = GetFolder("Personal Folders\Deleted Items")

IC = objDestinationFolder.Items.Count()
For I = IC To 1 Step -1
objDestinationFolder.Items(I).Delete
Next I


Set objSourceItems = objNS.GetDefaultFolder(olFolderDeletedItems).Items

IC = objSourceItems.Count()
For I = IC To 1 Step -1
objSourceItems(I).Delete
Next I


End Sub