Excel VBA創建Outlook電子郵件規則以將傳入消息移動到特定文件夾

Question

我有一個工作的excel電子表格，當單擊某個按鈕時，它將從excel電子表格中獲取一個數字列表，並將它們放在一個Outlook規則中，該規則將帶有該數字的電子郵件移動到文件夾中。 經過大量研究，我創建了一個應該完全做到這一點的潛艇。 問題在於，在初始化MoveOrCopyToRuleAction的子節中，代碼退出並顯示“內存不足”錯誤。 我知道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