在较新的Outlook中将当前电子邮件作为附件附加到当前电子邮件答复中

时间:2018-11-15 02:40:52

标签: vba outlook outlook-vba

我有此代码:

Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strSubject As String

Select Case True
Case (InStr(Item.Subject, "PIR") > 0)
    If InStr(Item.Subject, "RE") > 0 Then
        strSubject = Replace(Item.Subject, "RE:", "", vbTextCompare)
    Else
    End If

    If InStr(Item.Subject, "FW") > 0 Then
        strSubject = Replace(Item.Subject, "FW:", "", vbTextCompare)
    Else
    End If

    If strSubject = "" Then
    Else
        Set objRecip = Item.Recipients.Add("email.address@domain.com")
        objRecip.Type = olBCC
        objRecip.Resolve
        Item.Subject = Trim(strSubject)
        Item.Save
        Item.Attachments.Add Item
        Item.Save
    End If
Case (InStr(Item.Subject, "PIQ") > 0)
    If InStr(Item.Subject, "RE") > 0 Then
        strSubject = Replace(Item.Subject, "RE:", "", vbTextCompare)
    Else
    End If

    If InStr(Item.Subject, "FW") > 0 Then
        strSubject = Replace(Item.Subject, "FW:", "", vbTextCompare)
    Else
    End If

    If strSubject = "" Then
    Else
        Set objRecip = Item.Recipients.Add("email.address@domain.com")
        objRecip.Type = olBCC
        objRecip.Resolve
        Item.Subject = Trim(strSubject)
        Item.Save
        Item.Attachments.Add Item
        Item.Save
    End If
'#### Enable the below to capture more doc types ####
'    Case (InStr(Item.Subject, "ABC") > 0)
'        If InStr(Item.Subject, "RE") > 0 Then
'            strSubject = Replace(Item.Subject, "RE:", "", vbTextCompare)
'        Else
'        End If
'
'        If InStr(Item.Subject, "FW") > 0 Then
'            strSubject = Replace(Item.Subject, "FW:", "", vbTextCompare)
'        Else
'        End If
'
'        If strSubject = "" Then
'        Else
'            Set objRecip = Item.Recipients.Add("email.address@domain.com")
'            objRecip.Type = olBCC
'            objRecip.Resolve
'            Item.Subject = Trim(strSubject)
'            Item.Save
'        End If
End Select

End Sub

这位于ThisOutlookSession中,并检查所有已发送的电子邮件以查找特定主题。

此代码在我的Outlook 2010上有效,但是在其他Outlook上,它在“ Item.Attachments.Add Item”处错误,提示“消息无法附加到自身上”。

在新版本中是否可以解决这个问题?


在Outlook 2010上,用户将点击回复(或转发)以回复向其发送电子邮件的人。

需要附加一份副本,以便通过代码添加的电子邮件地址(密件抄送“ email.address@domain.com”)获得一份副本。该电子邮件地址是系统电子邮件地址,可剥离附件并将其保存到作业下的工作流软件中(在主题行中)。这就是为什么我们需要发送电子邮件的附件,因此,如果用户说“在此工作上执行xyz”,则该电子邮件将保存到我们的工作流系统中。

1 个答案:

答案 0 :(得分:0)

为什么不创建新消息并将当前消息附加到该新消息上?

您可以尝试为此使用Redemption(这不会阻止您用脚射击自己),但是您很可能最终会在附件所附加的邮件上得到空的邮件附件内嵌附件,因为“兑换”会在创建后立即复制内嵌附件。