Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Sub RunRulesSecondary()
- Dim oStores As Outlook.Stores
- Dim oStore As Outlook.Store
- Dim olRules As Outlook.Rules
- Dim myRule As Outlook.Rule
- Dim olRuleNames() As Variant
- Dim name As Variant
- ' Enter the names of the rules you want to run
- olRuleNames = Array("Rule1")
- Set oStores = Application.Session.Stores
- For Each oStore In oStores
- On Error Resume Next
- ' use the display name as it appears in the navigation pane
- If oStore.DisplayName <> "email@domain.ddns.net" Then
- Set olRules = oStore.GetRules()
- For Each name In olRuleNames()
- For Each myRule In olRules
- Debug.Print "myrule " & myRule
- If myRule.name = name Then
- ' inbox belonging to oStore
- ' need GetfolderPath functionhttp://slipstick.me/4eb2l
- myRule.Execute ShowProgress:=True, Folder:=GetFolderPath(oStore.DisplayName & "Inbox")
- ' current folder
- ' myRule.Execute ShowProgress:=True, Folder:=Application.ActiveExplorer.CurrentFolder
- End If
- Next
- Next
- End If
- Next
- End Sub
- Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
- Dim oFolder As Outlook.Folder
- Dim FoldersArray As Variant
- Dim i As Integer
- On Error GoTo GetFolderPath_Error
- If Left(FolderPath, 2) = "\" Then
- FolderPath = Right(FolderPath, Len(FolderPath) - 2)
- End If
- 'Convert folderpath to array
- FoldersArray = Split(FolderPath, "")
- Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
- If Not oFolder Is Nothing Then
- For i = 1 To UBound(FoldersArray, 1)
- Dim SubFolders As Outlook.Folders
- Set SubFolders = oFolder.Folders
- Set oFolder = SubFolders.Item(FoldersArray(i))
- If oFolder Is Nothing Then
- Set GetFolderPath = Nothing
- End If
- Next
- End If
- 'Return the oFolder
- Set GetFolderPath = oFolder
- Exit Function
- GetFolderPath_Error:
- Set GetFolderPath = Nothing
- Exit Function
- End Function
Add Comment
Please, Sign In to add comment