macro to move messages from Sent Items from specific mailbox address

**wotadude** · 03-24-2009, 07:36 PM

In outlook i manage multiple mailboxes.
And when sending a message i select from which email address i am sending it from (on behalf of).

I need a macro to move all sent items from my personal mailbox for a specific "From" address to the specific mailbox sent items.
As mail items sent on behalf are filed in the personal sent items, not that of the behalf of mailbox.

i would like to run this on demand (via toolbar button) and an option to run on outlook close and/or outlook open/start-up.

**wotadude** · 03-30-2009, 05:59 PM

any solutions fellow forumists?

**ExlGuru** · 03-31-2009, 03:52 AM

Try this code may be helpful for you:

Code:

Sub CopySentItemsMessagesToPSTFile(PSTFilePath As String)
On Error Resume Next

Dim objNS As Outlook.NameSpace
Dim objSentItemsFolder As Outlook.MAPIFolder, objDestinationFolder As
Outlook.MAPIFolder
Dim objItem As Object
Dim intX As Integer

Set objNS = Application.GetNamespace("MAPI")
Set objSentItemsFolder = objNS.GetDefaultFolder(olFolderSentMail)

objNS.AddStore PSTFilePath 'PST will be created if it doesn't exist
Set objDestinationFolder = objNS.Folders.GetLast 'Get the PST we just
added
Set objDestinationFolder = objDestinationFolder.Folders("Inbox")
If Err.Number <> 0 Then
'Inbox doesn't exist; create it
Set objDestinationFolder = objDestinationFolder.Folders.Add("Inbox",
olFolderInbox)
End If

For intX = objSentItemsFolder.Items.Count To 1 Step -1
Set objItem = objSentItemsFolder.Items(intX)
objItem.Move objDestinationFolder
Next

Leave:
Set objNS = Nothing
Set objSentItemsFolder = Nothing
Set objDestinationFolder = Nothing
Set objItem = Nothing
End Sub

**bugmenot** · 05-01-2009, 05:12 PM

Private WithEvents sentItems As Items

Private Sub Application_Startup()
Dim objNS As NameSpace
Dim objRecipient As Recipient
Dim objFolder As MAPIFolder

Set objNS = Me.GetNamespace("MAPI")
Set objRecipient = objNS.CreateRecipient(objNS.CurrentUser.Address)
objRecipient.Resolve

If objRecipient.Resolved Then
Set objFolder = objNS.GetDefaultFolder(olFolderSentMail)
Set sentItems = objFolder.Items
Set objFolder = Nothing
Else
MsgBox ("Error: Name Not Resolved - Please Contact Jon P")
End If
Set objRecipient = Nothing
Set objNS = Nothing
End Sub

Private Sub sentItems_ItemAdd(ByVal Item As Object)
Dim objItem As Outlook.MailItem
Dim objNS As NameSpace
Const g_PR_SMTP_ADDRESS_W = &H39FE001F

If (TypeOf Item Is Outlook.MailItem) Then
Set objItem = Item
Set objSession = CreateObject("MAPI.Session")
objSession.Logon "", "", False, False
strEntryID = objItem.EntryID
strStoreID = objItem.Parent.StoreID
Set objMessage = objSession.GetMessage(strEntryID, strStoreID)
strAddress = objMessage.Sender.Address

If Not InStr(strAddress, "@") Then
On Error Resume Next
strAddress = objMessage.Sender.Fields(g_PR_SMTP_ADDRESS_W).Value
End If
objSession.Logoff
Set objMessage = Nothing
Set objSession = Nothing

Select Case True
Case InStr(LCase(strAddress), "jon.p@xxx.com")
strMailBox = "Mailbox - Jon P"
Case Else
strMailBox = ""
End Select
Set objNS = Application.GetNamespace("MAPI")
Set CDS_SentItems = objNS.Folders(strMailBox).Folders("Sent Items")
objItem.Move CDS_SentItems
Set CDS_SentItems = Nothing
Set objNS = Nothing
Set objItem = Nothing
End If
End Sub