使用 VBA 将 Outlook 文件夹中的电子邮件移动到子文件夹？

Question

我已将邮件的所有主题从主文件夹导出到项目第一个模块中的 excel 电子表格中。

对于第二个模块或代码。我想根据搜索电子邮件主题将从主文件夹中提取的电子邮件移动到子文件夹。我在电子表格的单独列中详细说明了子文件夹名称。

第 3 列 - 主题电子邮件 第 8 列 - 子文件夹名称

主文件夹中的每个电子邮件主题都是唯一的，所以我使用“查找方法”然后将电子邮件移动到子文件夹。由于每次提取时列表都是动态的，因此我决定使用数组，以便在电子邮件列表更改时进行迭代。

例如，代码必须将电子邮件放在主文件夹中，主题为“A”到文件夹“1”。

Email subject        Folder name 
(Column 3)           (Column 8)
A                     1
B                     1
C                     2
D                     2
E                     1

Sub MovingEmails_Invoices()

  'Declare your Variables
    Dim i As Object
    Dim items As Outlook.items
    Dim subfolder As Outlook.Folder 'this will be the folder you want to move the Mail to

    'Set Outlook Inbox Reference
    Set OP = New Outlook.Application
    Set NS = OP.GetNamespace("MAPI")

    'To loop through subfolder and its folders
    Set rootfol = NS.Folders("SYNTHES-JNJCZ-GBS.DE.AT.CH@ITS.JNJ.com")
    Set Folder = rootfol.Folders("Austria")


'The list for invoice numbers and folders is dynamic
'Each subject being searched is different

Dim Listmails() As Variant
Dim Rowcount As Variant
Dim Mailsubject As Variant
Dim FolderName As Variant
Dim MS As Variant

 'Establish the array based on the mailbox extract
  Sheets("files").Activate
  Listmails = Range("A2").CurrentRegion

 'Ititerate through the array which is dynamic (One-dimensional)
 For Rowcount = LBound(Listmails) To UBound(Listmails)

 '3rd row for email subject
  Mailsubject = Application.WorksheetFunction.Index(Listmails, Rowcount, 3)
  MS = "[subject] = '" & Mailsubject & "'"

 'Find the email based on the array for email subject
  Set i = items
  Set i = Folder.items.Find(MS)

  If i.Class = olMail Then

 '8th row for folder name
  FolderName = Application.WorksheetFunction.Index(Listmails, Rowcount, 8)
  Set subfolder = rootfol.Folders(FolderName)

  'If email is found then mark it as read
  item.UnRead = False

 'Move it to the subfolder based on the array for folder name
  i.Move subfolder

End If
Next Rowcount

End Sub

执行以下代码时出错，但我不知道为什么

If i.Class = olMail Then

我只为迭代部分添加了改进的代码。我有错误

Set items = items.Restrict(MS)

'Ititerate through the array which is dynamic (One-dimensional)
For Rowcount = LBound(Listmails) To UBound(Listmails)

'3rd row for email subject 'used DASL Filter
Mailsubject = Application.WorksheetFunction.Index(Listmails, Rowcount, 3)
MS = "urn:schemas:mailheader:subject LIKE \'%" & Mailsubject & "%\'"

    'Find the email based on the array for email subject
    Set myitems = Folder.items
    Set myrestrictitem = myitems.Restrict(MS)

      For Each i In myrestrictitem
      If TypeOf i Is Mailitem Then

         '8th row for folder name
         FolderName = Application.WorksheetFunction.Index(Listmails, Rowcount, 8)
         Set subfolder = rootfol.Folders(FolderName)

         'If email found then mark it as read
         i.UnRead = False

         'Move it to the subfolder based on the array for folder name
         i.Move subfolder

      Else
      End If
      Next

Next Rowcount

End Sub

Answer 1

我只是查看您的部分代码，但我发现了至少两个大错误：

为什么要设置i 两次？还有items是什么？

Set i = items
Set i = Folder.items.Find(MS)

1：您是否想查看TypeOf i？

If i.Class = olMail Then

2：item 是什么？

item.UnRead = False

---

删除线

Set i = items

换行

If i.Class = olMail then

与

If TypeOf i Is MailItem Then

并在item.UnRead = False 行中将item 替换为i

Answer 2

我建议检查主题行作为子字符串，例如：

dim filter as string = "urn:schemas:mailheader:subject LIKE \'%"+ wordInSubject +"%\'"

此外，除了Find 之外，您还必须使用FindNext 或仅使用Restrict 方法：

Sub MovingEmails_Invoices()

  'Declare your Variables
    Dim i As Object
    Dim items As Outlook.items
    Dim subfolder As Outlook.Folder 'this will be the folder you want to move the Mail to

    'Set Outlook Inbox Reference
    Set OP = New Outlook.Application
    Set NS = OP.GetNamespace("MAPI")

    'To loop through subfolder and its folders
    Set rootfol = NS.Folders("SYNTHES-JNJCZ-GBS.DE.AT.CH@ITS.JNJ.com")
    Set Folder = rootfol.Folders("Austria")


'The list for invoice numbers and folders is dynamic
'Each subject being searched is different

Dim Listmails() As Variant
Dim Rowcount As Variant
Dim Mailsubject As Variant
Dim FolderName As Variant
Dim MS As Variant

 'Establish the array based on the mailbox extract
  Sheets("files").Activate
  Listmails = Range("A2").CurrentRegion

 'Ititerate through the array which is dynamic (One-dimensional)
 For Rowcount = LBound(Listmails) To UBound(Listmails)

 '3rd row for email subject
  Mailsubject = Application.WorksheetFunction.Index(Listmails, Rowcount, 3)
  MS = "urn:schemas:mailheader:subject LIKE \'%"& Mailsubject &"%\'"

 'Find the email based on the array for email subject
  Set items = Folder.Items
  Set items = items.Restrict(MS)
  i = resultItems.GetFirst()
  While Not IsNothing(i)
     If i.Class = olMail Then

       '8th row for folder name
        FolderName = Application.WorksheetFunction.Index(Listmails, Rowcount, 8)
        Set subfolder = rootfol.Folders(FolderName)

       'If email is found then mark it as read
        i.UnRead = False

        'Move it to the subfolder based on the array for folder name
        i.Move subfolder
        i = resultItems.GetNext()
   End While
End If

Next Rowcount

End Sub

您可以在以下文章中找到示例代码和说明：

• How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
• How To: Use Restrict method to retrieve Outlook mail items from a folder