Excel VBA создает правило электронной почты Outlook для перемещения входящих сообщений в определенную папку

Question

У меня есть электронная таблица Excel для работы, которая, когда нажимается определенная кнопка, получает список чисел из электронной таблицы Excel и помещает их в правило внешнего вида, которое будет перемещать электронные письма с этим номером в папку.После долгих исследований я создал саб, который должен делать именно это.Проблема в том, что в разделе sub, который инициализирует MoveOrCopyToRuleAction, код завершается с ошибкой «Out of Memory».Я знаю, что в Excel не хватает памяти, так как он не работает с большим количеством данных.Количество условий, которые оно использует, вероятно, 4 или 5 чисел в любой момент времени.Хорошо ... я перестану объяснять и доберусь до кода:

Sub RemoveandCreateRule()
Dim outlookObject As outlook.Application            'We need to define the actual Outlook Application
Dim oNamespace As Namespace                         'Define the Namespace from the Application (should also pull the current session)
Dim Account As outlook.Folder                       'Define the email account that we will be using to get and send rules
Dim targetFolder As outlook.Folder                  'The target folder to move emails to.
Dim serverRules As outlook.Rules                    'The current rules in the server.
Dim newRule As outlook.Rule                         'The object to store the new rule in (which will be uploaded to the server.
Dim newRuleAction As outlook.RuleAction             'The object for the action in the rule
Dim oConditionSubject As outlook.TextRuleCondition  'The object containing the condition for the rule
Dim newSrArray() As String                          'The array to store all the numbers in (to be put in the rule conditions)
Dim newSrListing As String

'-----------------------------------------------------------------------------------------------------------------
'Start initializing Account related variables.
'Start wtih the Application (getting the current Outlook Application)
Set outlookObject = CreateObject("Outlook.Application")

'Then get the namespace from the current outlook application (specifically the "MAPI" namespace)
Set oNamespace = outlookObject.GetNamespace("MAPI")

'Once the namespace is selected, set the email account by finding the one that starts with "email"
For i = 1 To oNamespace.Accounts.Count
    If InStr(1, oNamespace.Accounts(i).DisplayName, "email") = 1 Then
        Set Account = oNamespace.Folders(oNamespace.Accounts(i).DisplayName)
    End If
Next

'Now we need to get the folder in the "email" account named "My SRs". If it doesn't exist, create a new one.
For i = 1 To Account.Folders("Inbox").Folders.Count
    If Account.Folders("Inbox").Folders(i) = "My SRs" Then
        Set targetFolder = Account.Folders("Inbox").Folders(i)
    End If
Next

If targetFolder Is Nothing Then
    Set targetFolder = Account.Folders.Add("Inbox").Folders("My SRs")
End If

'-------------------------------------------------------------------------------------------------------------------
'Start initializing rule related variables.
'Initialize the server rules and get the current ones. Delete "My SRs" rule if it exists.
Set serverRules = Account.Store.GetRules()

For counter = 1 To serverRules.Count
    If serverRules.Item(counter).Name = "My SRs" Then   ' NewRuleName already exists
        serverRules.Remove ("My SRs")                     ' So remove the rule from your collection of rules
        serverRules.Save                                     ' Send your modified rule collection back to the Exchange server
    End If
Next


'Initialize the new rule
Set newRule = serverRules.Create("My SRs", olRuleReceive)

'Set the alert that tells us when a new email comes in.
Set newAlertAction = newRule.Actions.NewItemAlert
With newAlertAction
    .Enabled = True
    .text = "New mail for current case"
End With

'-------------------------------------------------------------------------------------------------------------------
'Get the list of SR's separate them into an array of strings, and then add them as subject conditions in the rule.

Set oConditionSubject = newRule.Conditions.Subject
newSrListing = buildSRnumberList  'Another function I built that works just fine.
newSrArray = Split(newSrListing)

With oConditionSubject
    .Enabled = True
    .text = newSrArray
End With

'Set the action that moves the email to the target folder
Set newRuleAction = newRule.Actions.CopyToFolder
With newRuleAction
    .Folder = targetFolder      ' Tell the rule what target folder to use
    .Enabled = True             ' Make the rule active (This is where I am getting my error and exit.
End With

' Update the Exchange server with your new rule!
serverRules.Save

MsgBox ("Your email rules were updated and contain the following SR Numbers: " & newSrListing)

Answer 1

Ошибка на serverRules.Save была исправлена ​​заменой Dim newRuleAction As outlook.RuleAction на Dim newRuleAction As Outlook.MoveOrCopyRuleAction.Это может исправить вашу ошибку.

For counter = 1 To serverRules.Count обязательно завершится «индексом вне диапазона».

В общем случае используйте цикл обратного отсчета при перемещении или удалении.В этом случае есть другой метод.

Option Explicit

Private Sub RemoveandCreate_MoveOrCopy_Rule()

' Set a reference to Outlook XX.X Object Library

Dim outlookObject As Outlook.Application            'We need to define the actual Outlook Application
Dim oNamespace As Namespace                         'Define the Namespace from the Application (should also pull the current session)
Dim Account As Outlook.Folder                       'Define the email account that we will be using to get and send rules

Dim inboxFolder As Outlook.Folder
Dim targetFolder As Outlook.Folder                  'The target folder to move emails to.

Dim serverRules As Outlook.rules                    'The current rules in the server.
Dim newRule As Outlook.Rule                         'The object to store the new rule in (which will be uploaded to the server.

Dim newAlertAction As RuleAction

'Dim newRuleAction As outlook.RuleAction
Dim newRuleAction As Outlook.MoveOrCopyRuleAction   'The object for the action in the rule

Dim oConditionSubject As Outlook.TextRuleCondition  'The object containing the condition for the rule

Dim newSrArray() As String                          'The array to store all the numbers in (to be put in the rule conditions)
Dim newSrListing As String

Dim i As Long

'-----------------------------------------------------------------------------------------------------------------
'Start initializing Account related variables.
'Start wtih the Application (getting the current Outlook Application)
Set outlookObject = CreateObject("Outlook.Application")

'Then get the namespace from the current outlook application (specifically the "MAPI" namespace)
Set oNamespace = outlookObject.GetNamespace("MAPI")

'Once the namespace is selected, set the email account by finding the one that starts with "email"
For i = 1 To oNamespace.Accounts.Count
    If InStr(1, oNamespace.Accounts(i).DisplayName, "email") = 1 Then
        Set Account = oNamespace.Folders(oNamespace.Accounts(i).DisplayName)
        Exit For    ' Ignore subsequent accounts
    End If
Next

Set inboxFolder = Account.Folders("Inbox")

'Now we need to get the folder in the "email" account named "My SRs". If it doesn't exist, create a new one.
On Error Resume Next
Set targetFolder = inboxFolder.Folders("My SRs")
'Turn error bypass off as soon as it has served the specific purpose 
On Error GoTo 0

If targetFolder Is Nothing Then
    Set targetFolder = inboxFolder.Folders.Add("My SRs")
End If

'-------------------------------------------------------------------------------------------------------------------
'Start initializing rule related variables.
'Initialize the server rules and get the current ones. Delete "My SRs" rule if it exists.
Set serverRules = Account.Store.GetRules()

On Error Resume Next
serverRules.Remove ("My SRs")                   ' Remove the rule from your collection of rules
'Turn error bypass off as soon as it has served the specific purpose 
On Error GoTo 0

'Initialize the new rule
Set newRule = serverRules.Create("My SRs", olRuleReceive)

'Set the alert that tells us when a new email comes in.
Set newAlertAction = newRule.Actions.NewItemAlert
With newAlertAction
    .Enabled = True
    .Text = "New mail for current case"
End With

'-------------------------------------------------------------------------------------------------------------------
'Get the list of SR's separate them into an array of strings, and then add them as subject conditions in the rule.

Set oConditionSubject = newRule.Conditions.Subject

' Not useful in the question without code for buildSRnumberList
'newSrListing = buildSRnumberList  'Another function I built that works just fine.

' For testing
newSrListing = "101 102 103 104"
newSrArray = Split(newSrListing)

With oConditionSubject
    .Enabled = True
    .Text = newSrArray
End With

'Set the action that copies the email to the target folder
Set newRuleAction = newRule.Actions.CopyToFolder
With newRuleAction
    .Folder = targetFolder      ' Tell the rule what target folder to use
    .Enabled = True
End With

' Update the Exchange server with your new rule!
serverRules.Save

MsgBox ("Your email rules were updated and contain the following SR Numbers: " & newSrListing)

End Sub