Outlook VBA代码问题：无法将指定邮件作为附件添加至新邮件

核心错误及修复点 #

• 附件添加逻辑颠倒
  原代码中email.Attachments.Add newEmail, olEmbeddeditem是把新建邮件添加到目标邮件的附件中，完全搞反了需求逻辑。正确写法是调用新建邮件的Attachments.Add方法，将找到的目标邮件作为附件插入：

  newEmail.Attachments.Add email, olEmbeddeditem
  

• 未定位到指定子文件夹
  需求明确要操作非默认收件箱的指定子文件夹，原代码仅定位到Inbox根目录，需补充子文件夹的定位代码（示例中假设子文件夹名为"指定子文件夹"）：

  Set inbox = outlookApp.GetNamespace("MAPI").Folders("test@gmail.com").Folders("Inbox")
  Set subFolder = inbox.Folders("指定子文件夹") ' 新增：定位到目标子文件夹
  

  后续遍历邮件时要使用subFolder.Items而非inbox.Items。

• 变量声明与使用不规范
  原代码声明了inboxFolder但实际用了未声明的inbox变量，建议统一变量名并规范使用outlookNamespace：

  Set outlookNamespace = outlookApp.GetNamespace("MAPI")
  Set inboxFolder = outlookNamespace.Folders("test@gmail.com").Folders("Inbox")
  Set subFolder = inboxFolder.Folders("指定子文件夹")
  

• 遍历邮件效率优化
  直接遍历所有邮件效率极低，改用Restrict方法筛选主题包含UNIQ ID的邮件：

  Dim filter As String
  filter = "@SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001F"" LIKE '%" & uniqueID & "%'"
  Dim filteredItems As Outlook.Items
  Set filteredItems = subFolder.Items.Restrict(filter)
  

• 处理空单元格
  跳过A列中的空单元格，避免无效搜索：

  If Trim(uniqueID) = "" Then GoTo NextID
  

修正后的完整代码 #

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
    Dim newEmail As Outlook.MailItem
    Dim filter As String
    Dim filteredItems As Outlook.Items
    
    ' 初始化Outlook对象
    Set outlookApp = New Outlook.Application
    Set outlookNamespace = outlookApp.GetNamespace("MAPI")
    ' 定位到非默认收件箱及指定子文件夹
    Set inboxFolder = outlookNamespace.Folders("test@gmail.com").Folders("Inbox")
    Set subFolder = inboxFolder.Folders("指定子文件夹") ' 替换为你的目标子文件夹名称
    
    ' 创建新邮件并显示
    Set newEmail = outlookApp.CreateItem(olMailItem)
    newEmail.Display
    
    ' 绑定Excel工作表及ID范围
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set idRange = ws.Range("A1:A10")
    
    ' 遍历每个UNIQ ID
    For Each idCell In idRange
        uniqueID = idCell.Value
        ' 跳过空单元格
        If Trim(uniqueID) = "" Then GoTo NextID
        
        ' 构建筛选条件，搜索主题包含UNIQ ID的邮件
        filter = "@SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001F"" LIKE '%" & uniqueID & "%'"
        Set filteredItems = subFolder.Items.Restrict(filter)
        
        ' 处理筛选结果（取第一个匹配的邮件）
        If filteredItems.Count > 0 Then
            Set email = filteredItems(1)
            ' 将匹配邮件添加为新邮件的附件
            newEmail.Attachments.Add email, olEmbeddeditem
        End If
        
NextID:
    Next idCell
End Sub

内容的提问来源于stack exchange，提问作者user19102522