我有一个工作的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)
答案 0 :(得分：0)
通过将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