创建在转发前删除附件的规则

Question

我的任务是创建一个自动报告系统，将来自 Google 数据工作室的报告上传到特定项目（在一个名为 Basecamp 的网站上）。报告始终包括电子邮件正文中的报告和附加的 PDF 文件。被发送到 Gmail 帐户（数据工作室拒绝向非 Google 帐户安排）。 Gmail 中的过滤器不能很好地与 Basecamp 系统配合使用，因此我使用过滤器将它们重新路由到 Outlook 帐户。在那里，我使用规则将每封电子邮件发送给 Basecamp 中的正确客户。

问题来了，Basecamp 显示了电子邮件的正文和附加的 PDF 版本，这使我们显示重复。

有没有办法创建一个宏，首先删除所有附件（或电子邮件正文），然后转发电子邮件。

它不能手动完成，它必须是自动完成的规则​​。请记住，我不是编码员，也从未做过这样的事情，所以请为我的愚蠢大脑保持简单！

提前感谢您！ 马库斯

PS：我找到了一个似乎是我想要的代码。

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("kto feature")) = 0 Then Exit Sub  'change subject text to your need
    If xEmail.Attachments.Count = 0 Then Exit Sub
    Set xForwardMail = xEmail.Forward
    With xForwardMail
        .HTMLBody = ""
        With .Recipients
            .Add "skyyang@addin88.com"    'change address to your own
            .ResolveAll
        End With
        .Send
    End With
End Sub

我正在尝试使该代码正常工作，并将主题更改为特定单词，然后将其路由到最终电子邮件帐户，然后过滤掉以正确的客户。但是代码似乎不起作用，它确实转发了电子邮件，但附件仍然存在。代码位于https://www.extendoffice.com/documents/outlook/5359-outlook-forward-attachment-only.html#a1

Answer 1

看来你需要稍微修改一下代码：

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 myattachments as Outlook.Attachments

    On Error Resume Next
    If Item.Class <> olMail Then Exit Sub
    Set xEmail = Item
    If InStrRev(UCase(xEmail.Subject), UCase("kto feature")) = 0 Then Exit Sub  'change subject text to your need
    If xEmail.Attachments.Count = 0 Then Exit Sub
    Set xForwardMail = xEmail.Forward
    
    Set myattachments = xForwardMail.Attachments 
 
    While myattachments.Count > 0 
      myattachments.Remove 1 
    Wend 

    With xForwardMail
        .HTMLBody = ""
 
        With .Recipients
            .Add "skyyang@addin88.com"    'change address to your own
            .ResolveAll
        End With
        .Send
    End With
End Sub

Attachments 类的Remove 方法从集合中移除一个对象。