Question

我有搜索主题的宏，如果找到则将电子邮件复制到另一个文件夹中。我的问题是它复制了4次电子邮件而不是只复制一次。如果我在原始文件夹中有10封电子邮件＆＃34; Left Ones＆＃34;然后，在搜索和复制后，我将在文件夹中发送40封电子邮件＆＃34;要删除＆＃34; 。欢迎任何帮助，谢谢。

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

并将其移至此块的末尾：

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

Answer 2

对于未来的搜索者，这里是工作代码，用于在子文件夹中查找具有给定主题的所有电子邮件 - 收件箱\左侧 - 并将其复制到另一个子文件夹中 - 收件箱\要删除 - （请注意，它将省略未送达的通知）：

        Sub Search_Inbox_Subfolder_Left_Ones()

        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
        Dim myCopiedItem As Object

        subject_to_find = "something to find"

        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

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

            For i = filteredItems.Count To 1 Step -1

             If filteredItems(i).Class = olMail Then

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

             End If

            Next i

        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

Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

复制找到的电子邮件4次

2 个答案: