(This is a response to thread605-1547504: How to move Outlook items fo pst folders via VBA)

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/Outlook/microsoft.public.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



 

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