Hello,

I would like to automate a bit my Outlook 2003. I have an Exchange account but my emails are delivered to my pst to control the size of the mailbox. The problem is that I use ActiveSync to check emails on my Sony Xperia phone when I'm away from my desk but because they're moved to the pst from time to time, I don't see them if Outlook is running.

I would like to learn a VBA code to pick the read messages from my Exchange Inbox and move them to my pst Inbox folder. This way all the unread messages stay in my Exchange mailbox, I can set the delivery of new mail to happen to that mailbox and have it organized by the end of the day.The idea is to return to the old situation of delivering the emails to the Exchange mailbox as I can control where do I want the emails to be delivered. If possible also to move the Sent Items from the Exchange to Sent Items in pst that would be great.

Someone kindly developed some initial code for this but it's doing the opposite of what I need since it's moving the items from my PST to my Exchange Inbox. What I need is to move from the Exchange to my pst!!

[VBA]Sub Move()
Dim Msg As Outlook.MailItem
Dim Itms As Outlook.Items
Dim i As Long
Dim MyPSTInbox As Outlook.MAPIFolder

Dim objNS As Outlook.NameSpace
Set objNS = GetNS(Me.Application)
Set Itms = GetItems(GetNS(GetOutlookApp), olFolderInbox)
Set MyPSTInbox = objNS.Folders("Mailbox - Coelho, Rui Pedro (GE Indust, ConsInd)").Folders("Inbox")

' need to step backwards in case we do need to move a msg
For i = Itms.Count To 1 Step -1
If IsMail(Itms.Item(i)) Then
' check unread property and move to other folder
If Itms.Item(i).UnRead = False Then
Itms.Item(i).Move MyPSTInbox
End If
End If
Next i
End Sub
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function

Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
Set GetOutlookApp = Outlook.Application
End Function

Function GetNS(ByRef app As Outlook.Application) _
As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function

Function GetItems(olNS As Outlook.NameSpace, _
folder As OlDefaultFolders) As Outlook.Items
Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function [/VBA]

Someone in other forum told me:
"Have you tried changing your first loop to use the items in MyPSTInbox, instead of your Exchange Inbox items?
Your current loop goes through the items in your exchange inbox. Since I use Outlook 2007, I can't test out any code, but there's probably an Items property in MyPSTInbox and if so, definitely a Count property as well. Use that Count to loop through instead of Itms.Count, and check the Item in MyPSTInbox, instead of the item in Itms."

But I have no idea what that means

Can someone help on this one?
Thanks!

I store all of my emails and I've been wanting to do this same thing. It took me several days to come to this solution.

There are 2 parts to this: 1) GetFolder Function, allows VBA to select folders outside of the server (pst folders); 2) CleanOutlook, several sub functions here... moving Sent Items to my Sent Items pst, etc...



'================================================= ==
'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

'------------------------------

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.Restri ct("[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

'------------------------------


Hope this helps