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

KadamWiser

New Member
Outlook version
Outlook 2016 64 bit
Email Account
Exchange Server
#1
When I manually move an email to a #folder I want a popup asking me if I want to create a rule called #folder to always move mails from its #sender to the #folder.

I need to listen for BeforeItemMove event on the Inbox folder. In the handler, I need to conditionalty show a message box asking to create a rule. And then use the Outlook Rules API to create a rule.

I'm not good at all in VBA. I wrote:
Code:
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
 

Michael Bauer

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
#2
In order to receive an event you need to declare a variable for the object with the With Events statement:
Code:
Private WithEvents Inbox As Outlook.Folder

Private Sub Application_Startup()
  Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
End Sub
Now you can select the variable from the dropdown box upper left, then select the event you want from the one right hand.

Since the variable will be set in the Startup event, you need to restart Outlook after any code changes, or execute that method manually by placing the cursor into it, then pressing f5.
 

KadamWiser

New Member
Outlook version
Outlook 2016 64 bit
Email Account
Exchange Server
#3
I worked on it:

Code:
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
Still not working :(
 

KadamWiser

New Member
Outlook version
Outlook 2016 64 bit
Email Account
Exchange Server
#4
Code:
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
 

Michael Bauer

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
#5
Is objFolder_BeforeItemMove being called? You can test it by setting a breakpoint on to that line of code.
 

Similar threads

Top