VBA to Move (not Copy) Sent Items?

[Rhudi]

I have a feeling this isn't doable (nor is strictly a VBA question).

I have a rule that will "execute after send" anything that is sent to my cell phone's email (SMS).

The rule only has "Move a Copy", not "Move".

I have a folder under Sent Items that I want to hold only those emails. They are still technically under "Sent Items", just moved to a folder nested within.

I am hoping that threre may be a way to enhance this:


Sub RunToCellRule()
Dim st As Outlook.Store, myRules As Outlook.Rules, rl As Outlook.Rule, runrule$, rulename$

rulename = "To Cell"

Set st = Application.Session.DefaultStore

Set myRules = st.GetRules

For Each rl In myRules
If rl.RuleType = olRuleSend Then
If rl.Name = rulename Then
rl.Execute ShowProgress:=True, Folder:=st.GetRootFolder.Folders("Sent Items"), IncludeSubfolders:=False, RuleExecuteOption:=olRuleExecuteAllMessages
runrule = rl.Name
End If
End If
Next

rulename = "Rule executed: [" & runrule & "]"
MsgBox rulename, vbInformation, "Macro: RunToCellRule"

Set rl = Nothing
Set st = Nothing
Set myRules = Nothing
End Sub

If "Move" isn't an option, once a "Copy" is made, maybe "Delete" it from sent root folder?

[gmayor]

You could setup an event to process messages added to the sent items folder and if they meet the required criteria, move them to the named folder e.g. in the ThisOutlookSession module add the following code. Change someone@somewhere.com to the e-mail address you wish to process. Then either run the macro Application_Startup or restart Outlook to run it automatically. Send a message to that address and the message should be moved from the Sent folder to the named folder (here 'Forwarded' - which must exist)


Option Explicit

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
'default local Sent items
Set Items = objNS.GetDefaultFolder(olFolderSentMail).Items
lbl_exit:
Exit Sub
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
Dim olFolder As Folder
Dim olMsg As MailItem
Const strSubFolder As String = "Forwarded" 'Change this line as appropriate
On Error GoTo ErrorHandler
If TypeName(item) = "MailItem" Then
Set olFolder = Session.GetDefaultFolder(olFolderSentMail).folders(strSubFolder)
Set olMsg = item
If olMsg.Recipients(1).Address = "someone@somewhere.com" Then 'Change this line as appropriate
olMsg.Move olFolder
End If
End If
lbl_exit:
Set olMsg = Nothing
Set olFolder = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Err.Clear
GoTo lbl_exit
End Sub