Question

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

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

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

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

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

def gen_input(n):
    random.seed(0)
    return tuple(
        tuple(sorted(set([random.randint(0, n - 1) for _ in range(random.randint(n // 2, n - 1))])))
        for _ in range(random.randint(n // 2, n - 1)))


def equal_output(a, b):
    return np.all(a == b)


input_sizes = tuple(int(2 ** (2 + (3 * i) / 4)) for i in range(13))
print('Input Sizes:\n', input_sizes, '\n')


runtimes, input_sizes, labels, results = benchmark(
    funcs, gen_input=gen_input, equal_output=equal_output,
    input_sizes=input_sizes)


plot_benchmarks(runtimes, input_sizes, labels, units='ms')
plot_benchmarks(runtimes, input_sizes, labels, units='ms', zoom_fastest=2)

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)

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中将i替换为item.UnRead = False

Answer 2

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

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

此外，除了FindNext之外，还必须使用Find或仅使用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

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

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

2 个答案: