使用Excel VBA创建Outlook规则

Question

我必须处理大约8000封电子邮件，并将它们分类到Outlook（2013）中的特定文件夹中。因此，我已经通过Excel列表在Outlook中创建了文件夹。该电子表格在文件夹名称旁边包含发件人/收件人的电子邮件地址。因此，我想按照以下示例创建自动规则：

电子邮件->被sheet1.cells（i，4）接收->移至文件夹（= sheet1.cells（i，5）

通过Google-ing，我创建了以下代码：

Sub createOutlookRule()
Dim appOutlook As Outlook.Application
Dim olRules As Outlook.Rules
Dim myRule As Outlook.Rule
Dim moveToAction As Outlook.MoveOrCopyRuleAction
Dim fromAction As Outlook.ToOrFromRuleCondition
Dim myInbox As Outlook.Folder
Dim moveToFolder As Outlook.Folder

For i = 2 To 5
Set appOutlook = New Outlook.Application
Set myInbox = appOutlook.Session.GetDefaultFolder(olFolderInbox)

Set olRules = appOutlook.Session.DefaultStore.GetRules()
Set myRule = olRules.Create(Sheet2.Cells(i, 1), olRuleReceive)
Set fromAction = myRule.Conditions.From

a = Sheet2.Cells(i, 3)

Set moveToFolder = myInbox.Folders("Mifid").Folders(a)

With fromAction
.Enabled = True

If IsEmpty(Sheet2.Cells(i, 4)) Then GoTo 4 Else

.Recipients.Add (Sheet2.Cells(i, 4))

If IsEmpty(Sheet2.Cells(i, 5)) Then GoTo 3 Else

.Recipients.adds (Sheet2.Cells(i, 5))
3:

End With

Set moveToAction = myRule.Actions.moveToFolder

With moveToAction
.Enabled = True
.Folder = moveToFolder
End With
olRules.Save
4:
Next i
End Sub

这实际上创建了规则，但到目前为止在移动规则方面无济于事（我仍在研究解决方案...如果有人有想法，请随时告诉我）

无论如何，现在我已经针对发送的项目进行了调整，但是在“移动部分”期间出现了错误

代码：

Sub createOutlookRuleSENTITEMS()
Dim appOutlook As Outlook.Application
Dim olRules As Outlook.Rules
Dim myRule As Outlook.Rule
Dim moveToAction As Outlook.MoveOrCopyRuleAction
Dim SENTAction As Outlook.ToOrFromRuleCondition
Dim myInbox As Outlook.Folder
Dim moveToFolder As Outlook.Folder

For i = 2 To 5
Set appOutlook = New Outlook.Application
Set myInbox = appOutlook.Session.GetDefaultFolder(olFolderInbox)

Set olRules = appOutlook.Session.DefaultStore.GetRules()
Set myRuleSENT = olRules.Create(Sheet2.Cells(i, 1), olRuleSend)
Set TOAction = myRuleSENT.Conditions.SentTo

a = Sheet2.Cells(i, 3)

Set moveToFolder = myInbox.Folders("Mifid").Folders(a)

With TOAction
.Enabled = True
If IsEmpty(Sheet2.Cells(i, 4)) Then GoTo 4 Else
.Recipients.Add ("test@example.com")
If IsEmpty(Sheet2.Cells(i, 5)) Then GoTo 3 Else
.Recipients.adds (Sheet2.Cells(i, 5))
3:
End With
Set moveToAction = myRuleSENT.Actions.moveToFolder

With moveToAction
.Enabled = True
.Folder = moveToFolder
End With
olRules.Save
4:

Next i
End Sub

错误消息：运行时错误... 无效的操作。无法启用此规则操作，因为规则对于规则类型是只读的或无效的，或者该操作与该规则上的其他操作冲突

有什么想法吗？