使用Excel VBA移动已发送项目的Outlook规则

Question

我必须将大约8000封电子邮件分类到Outlook(2013(中的特定文件夹中。

我通过Excel列表在Outlook中创建了文件夹。此电子表格在文件夹名称旁边包含发件人/收件人的电子邮件地址。

我想创建规则，按照这个例子：

电子邮件->由薄片1接收。细胞(i，4(->移动到文件夹=活页1.单元格(i，5(

通过谷歌搜索，我创建了这个代码：

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 ("[e-mail]")
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

错误消息：

运行时错误
无效操作。无法启用该规则操作，因为该规则是只读的或对该规则类型无效，或者该操作与规则上的另一个操作冲突

Answer 1

已发送项目的规则接口允许复制而非移动。(并不能证明这是不可能的。(

Option Explicit
Sub createOutlookRuleSENTITEMS()
' Reference Outlook nn.n Object Library
Dim appOutlook As Outlook.Application
Dim olRules As Outlook.Rules
Dim myRuleSENT As Outlook.Rule
Dim ToCondition As Outlook.ToOrFromRuleCondition
Dim CopySentItemRuleAction As Outlook.MoveOrCopyRuleAction
Dim myInbox As Outlook.Folder
Dim copyToFolder As Outlook.Folder
Dim i As Long
Set appOutlook = New Outlook.Application
Set myInbox = appOutlook.Session.GetDefaultFolder(olFolderInbox)
For i = 2 To 5

Set olRules = appOutlook.Session.DefaultStore.GetRules()
Debug.Print "Sheet2.Cells(i, 1): " & Sheet2.Cells(i, 1)
Set myRuleSENT = olRules.Create(Sheet2.Cells(i, 1), olRuleSend)

Set ToCondition = myRuleSENT.Conditions.SentTo

Dim a As String
a = Sheet2.Cells(i, 3)
Debug.Print "a: " & a

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

With ToCondition
.Enabled = True

Debug.Print "Sheet2.Cells(i, 4): " & Sheet2.Cells(i, 4)

If Not IsEmpty(Sheet2.Cells(i, 4)) Then

.Recipients.Add ("[e-mail]")

If Not IsEmpty(Sheet2.Cells(i, 5)) Then
.Recipients.Add (Sheet2.Cells(i, 5))
End If

' The rules interface for sent items allows copy not move.
' (Does not prove it impossible.)
'
'Action is to copy, not move, the sent item
Dim oCopyTarget As Outlook.Folder

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

Set CopySentItemRuleAction = myRuleSENT.Actions.copyToFolder
With CopySentItemRuleAction
.Enabled = True
.Folder = copyToFolder
End With

olRules.Save

End If
End With
Next i
Debug.Print "Done."
End Sub