匹配、复制和粘贴文件夹中的邮件作为附件到另一封邮件

问：

亲爱的所有人，我正在遭受一个代码，该代码将Outlook邮件作为附件从给定子文件夹匹配，复制并粘贴到空邮件中。

这个子文件夹位于我的收件箱中，它不是我的默认文件夹。我有 UNIQ ID，它们存储在给定 Excel 工作表的范围内。这些ID可以在上述文件夹的邮件主题中找到。

如果找到给定的邮件数量并复制了代码，我想停止该过程，但似乎是未来的项目，因为到目前为止，即使这不起作用。空邮件打开，但什么也没发生。.或不可见。你能帮我哪里出了错误吗？

Sub AttachEmailsToNewEmail()

    Dim outlookApp As Outlook.Application
    Dim outlookNamespace As Outlook.Namespace
    Dim inboxFolder As Outlook.MAPIFolder
    Dim subFolder As Outlook.MAPIFolder
    Dim email As Outlook.MailItem
    Dim ws As Worksheet
    Dim idRange As range
    Dim idCell As range
    Dim uniqueID As String
    
    
    Set outlookApp = New Outlook.Application
    Set inbox = outlookApp.GetNamespace("MAPI").Folders("[email protected]").Folders("Inbox")
    
    
    Dim newEmail As Outlook.MailItem
    Set newEmail = outlookApp.CreateItem(olMailItem)
    newEmail.Display
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set idRange = ws.range("A1:A10")
    
    ' Loop through each unique ID in the range
    For Each idCell In idRange
        uniqueID = idCell.Value
        
        ' Search for emails with the matching unique ID in the subject
        For Each email In inbox.Items
            If InStr(1, email.subject, uniqueID, vbTextCompare) > 0 Then
                ' Attach the email to the new email item
                email.Attachments.Add newEmail, olEmbeddeditem
                Exit For ' Exit the loop once a matching email is found
            End If
        Next email
    Next idCell
    
    
End Sub