VBA BeforeItemMove event create rule to always move to its folder.

this is not easy... there is no action trigger available 'move_item'... so if at all possible, you should recursively be listening to all folders, trapping a new item and than start macro from there... which I would not recommend (performance).
It could work for a specific folder (code available here)

Unless someone has a more clever idea?

Ok, let's make it easyer.

When I manually move an email to a #folder I'll select it and run a macro to create a rule called #sender to always move mails from its #sender to the #folder.

This sounds like what I need can someone please help me with syntax?

This would take a pretty big chunk of code.

Whould it be smaller in that way?

When I manually move an email to a #folder I'll select it and run a macro to create a rule called #sender to always move mails from its #sender to the #folder.

I tried to do my best but of course it is not working:

Function BeforeItemMove(Item, MoveTo, Cancel)

 Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Do you want to always move mails from this sender to this folder?"    ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2    ' Define buttons.
Title = "Create rule"    ' Define title.
Help = "DEMO.HLP"    ' Define Help file.
Ctxt = 1000    ' Define topic
        ' context.
        ' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then    ' User chose Yes.
    MyString = "Yes"    ' Perform some action.
    CreateRule (MoveTo)
Else    ' User chose No.
    MyString = "No"    ' Perform some action.
End If
End Function

Sub CreateRule()
 Dim colRules As Outlook.Rules
 Dim oRule As Outlook.Rule
 Dim colRuleActions As Outlook.RuleActions
 Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
 Dim oFromCondition As Outlook.ToOrFromRuleCondition
 Dim oExceptSubject As Outlook.TextRuleCondition
 Dim oInbox As Outlook.Folder
 Dim oMoveTarget As Outlook.Folder



 'Specify target folder for rule move action
 Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)

 'Assume that target folder already exists
 Set oMoveTarget = oInbox.Folders(MoveTo)



 'Get Rules from Session.DefaultStore object
 Set colRules = Application.Session.DefaultStore.GetRules()



 'Create the rule by adding a Receive Rule to Rules collection
 Set oRule = colRules.Create(MoveTo, olRuleReceive)



 'Specify the condition in a ToOrFromRuleCondition object
 'Condition is if the message is sent by "DanWilson"

 Set oFromCondition = oRule.Conditions.From

 With oFromCondition

 .Enabled = True

 .Recipients.Add (Sender)

 .Recipients.ResolveAll

 End With



 'Specify the action in a MoveOrCopyRuleAction object

 'Action is to move the message to the target folder

 Set oMoveRuleAction = oRule.Actions.MoveToFolder

 With oMoveRuleAction

 .Enabled = True

 .Folder = oMoveTarget

 End With






 'Update the server and display progress dialog

 colRules.Save

End Sub

Select allOpen in new window

Worked on it:

Private WithEvents objFolder As Outlook.Folder

Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
End Sub

Private Sub objFolder_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
    BeforeItemMove Item, MoveTo, Cancel
End Sub

Function BeforeItemMove(Item As Outlook.MailItem, MoveTo As Folder, Cancel As Boolean)

Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Do you want to always move mails from this sender to this folder?"    ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2    ' Define buttons.
Title = "Create rule"    ' Define title.
Help = "DEMO.HLP"    ' Define Help file.
Ctxt = 1000    ' Define topic
        ' context.
        ' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then    ' User chose Yes.
    MyString = "Yes"    ' Perform some action.
    CreateRule Item, MoveTo
Else    ' User chose No.
    MyString = "No"    ' Perform some action.
End If
End Function

Sub CreateRule(Item As Outlook.MailItem, MoveTo As Folder)
 Dim colRules As Outlook.Rules
 Dim oRule As Outlook.Rule
 Dim colRuleActions As Outlook.RuleActions
 Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
 Dim oFromCondition As Outlook.ToOrFromRuleCondition
 Dim oExceptSubject As Outlook.TextRuleCondition
 Dim oInbox As Outlook.Folder
 Dim oMoveTarget As Outlook.Folder

 'Specify target folder for rule move action
 Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)

 'Assume that target folder already exists
 Set oMoveTarget = oInbox.Folders(MoveTo.Name)

 'Get Rules from Session.DefaultStore object
 Set colRules = Application.Session.DefaultStore.GetRules()

 'Create the rule by adding a Receive Rule to Rules collection
 Set oRule = colRules.Create(MoveTo, olRuleReceive)

 oRule.Name = "Test123"
 'Specify the condition in a ToOrFromRuleCondition object
 'Condition is if the message is sent by "DanWilson"

 Set oFromCondition = oRule.Conditions.From

 With oFromCondition

 .Enabled = True

 .Recipients.Add (Item.Sender)

 .Recipients.ResolveAll

 End With


 'Specify the action in a MoveOrCopyRuleAction object

 'Action is to move the message to the target folder

 Set oMoveRuleAction = oRule.Actions.MoveToFolder

 With oMoveRuleAction

 .Enabled = True

 .Folder = oMoveTarget

 End With

 'Update the server and display progress dialog

 colRules.Save

End Sub

Select allOpen in new window