vba - 复制找到的电子邮件 4 次

Question

我有一个用于搜索主题的宏，如果找到，则将电子邮件复制到另一个文件夹中。我的问题是它将电子邮件复制了 4 次，而不是只复制了一次。如果我在原始文件夹“Left Ones”中有 10 封电子邮件，那么在搜索和复制之后，我将在“TO BE REMOVED”文件夹中有 40 封电子邮件。欢迎任何帮助，谢谢。

Sub Search_Inbox()

Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim subject_to_find As String
Dim myDestFolder As Outlook.Folder

subject_to_find = "something"

Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = OpenOutlookFolder("\\Mailbox - ME\Inbox\Left Ones")

strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & subject_to_find & "%'"

Set filteredItems = objFolder.Items.Restrict(strFilter)

If filteredItems.Count = 0 Then

    Debug.Print "No emails found"
    Found = False

Else
    Found = True

    For Each itm In filteredItems
    If itm.Class = olMail Then
    Debug.Print itm.Subject
    Debug.Print itm.ReceivedTime
    End If

  Set myDestFolder = Session.Folders("Mailbox - ME").Folders("TO BE REMOVED")

    For i = filteredItems.Count To 1 Step -1
            Dim myCopiedItem As Object

            Set myCopiedItem = filteredItems(i).Copy
            myCopiedItem.Move myDestFolder

    Next i

    Next itm

End If

'If the subject isn't found:
If Not Found Then
    'NoResults.Show
Else
   Debug.Print "Found " & filteredItems.Count & " items."
End If

Set myOlApp = Nothing

End Sub

Answer 1

之后

Else
    Found = True

添加行

Debug.Print filteredItems.Count

这是为了检查找到的项目数。这样，您就可以清楚地看到 VBA 是否真的找到了 40 封电子邮件(无论出于何种原因)，或者它是否只是在之后复制了 4 次。

也尝试改变

Next i

到

i = i + 1

编辑:

切开

Next itm

并将其移动到该 block 的末尾:

For Each itm In filteredItems
    If itm.Class = olMail Then
      Debug.Print itm.Subject
      Debug.Print itm.ReceivedTime
    End If
Next itm 'move it here