如何创建Outlook转发前自动删除附件的规则解决Basecamp重复问题

你找到的原有代码仅清空了转发邮件的正文内容，没有添加删除附件的逻辑，所以附件会保留并一起转发。下面提供两个可直接使用的修改版代码，以及零基础操作步骤：

版本1：保留附件，仅删除正文（适合只给Basecamp发PDF报告的场景） #

Public WithEvents ReceivedItems As Outlook.Items

Private Sub Application_Startup()
    Set ReceivedItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub ReceivedItems_ItemAdd(ByVal Item As Object)
    Dim xForwardMail As Outlook.MailItem
    Dim xEmail As MailItem
    On Error Resume Next
    If Item.Class <> olMail Then Exit Sub
    Set xEmail = Item
    ' 替换引号里的内容为你需要匹配的邮件主题关键词
    If InStrRev(UCase(xEmail.Subject), UCase("你要的主题关键词")) = 0 Then Exit Sub
    If xEmail.Attachments.Count = 0 Then Exit Sub
    Set xForwardMail = xEmail.Forward
    With xForwardMail
        ' 清空正文
        .HTMLBody = ""
        ' 清空默认加的转发抬头（比如“转发:”前缀、原始发件人信息），不需要可以删掉下面这行
        .Subject = xEmail.Subject
        With .Recipients
            ' 替换为你要转发的Basecamp项目邮箱地址
            .Add "你的Basecamp项目邮箱@basecamp.com"
            .ResolveAll
        End With
        .Send
    End With
    ' 可选：转发后自动删除原始Gmail转发过来的邮件，不需要可以删掉下面这行
    xEmail.Delete
End Sub

版本2：保留正文，删除所有附件（适合只给Basecamp发正文内容的场景） #

Public WithEvents ReceivedItems As Outlook.Items

Private Sub Application_Startup()
    Set ReceivedItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub ReceivedItems_ItemAdd(ByVal Item As Object)
    Dim xForwardMail As Outlook.MailItem
    Dim xEmail As MailItem
    Dim i As Long
    On Error Resume Next
    If Item.Class <> olMail Then Exit Sub
    Set xEmail = Item
    ' 替换引号里的内容为你需要匹配的邮件主题关键词
    If InStrRev(UCase(xEmail.Subject), UCase("你要的主题关键词")) = 0 Then Exit Sub
    Set xForwardMail = xEmail.Forward
    With xForwardMail
        ' 从最后一个附件开始往前删，避免索引出错
        For i = .Attachments.Count To 1 Step -1
            .Attachments.Remove i
        Next
        ' 清空默认加的转发抬头（不需要可以删掉下面这行）
        .Subject = xEmail.Subject
        With .Recipients
            ' 替换为你要转发的Basecamp项目邮箱地址
            .Add "你的Basecamp项目邮箱@basecamp.com"
            .ResolveAll
        End With
        .Send
    End With
    ' 可选：转发后自动删除原始Gmail转发过来的邮件，不需要可以删掉下面这行
    xEmail.Delete
End Sub

操作步骤（无编程基础也可完成） #

• 打开Outlook，按Alt + F11快捷键打开VBA编辑器
• 在左侧项目窗口找到ThisOutlookSession，双击打开编辑窗口
• 删除你之前粘贴的旧代码，把上面你需要的版本代码粘贴进去
• 按照代码里的中文注释，修改主题关键词和目标转发邮箱
• 保存代码，关闭VBA编辑器
• 开启Outlook宏权限：点击文件 > 选项 > 信任中心 > 信任中心设置 > 宏设置，选择启用所有宏，点击确定保存
• 重启Outlook即可生效

常见问题排查 #

• 如果没有自动转发：检查匹配的主题关键词是否和邮件主题对应（代码不区分大小写），确认宏权限已经开启
• 如果还是有重复内容：版本1已经完全清空了正文，Basecamp只会显示附件；版本2已经删除了所有附件，Basecamp只会显示正文
• 如果宏设置灰色不可修改：说明你的Outlook被企业管理员限制了权限，联系IT开通即可

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