从数组添加附件，无需创建文件路径

问题描述

我想合并草稿电子邮件（由另一个程序自动创建）中的附件，以便一封电子邮件可能包含多个附件。

我有三个数组：

• 附件 arrAtt()（来自原始电子邮件草稿）
• 原稿对应的电子邮件地址 arrAdd()
• 唯一的电子邮件地址 arrUnqAdd()

我正在为每个唯一的电子邮件地址创建一个新电子邮件。

我的挑战是从数组 arrAtt() 添加附件。

我知道 .Attachments.Add 是用来处理文件路径的。

有没有办法从 arrAtt() 添加附件？即不保存附件以创建文件路径？

Dim OpenItem As Object
Dim arrDraft() As MailItem 'all drafts
Dim arrAtt() As Attachment 'all attachments
Dim arrAdd() As String 'all email addresses
Dim arrUnqAdd() As String 'unique email addresses
Dim sTraddrUnique As String  'unique list of email addresses,delimited

For a = Application.Inspectors.Count To 1 Step -1
    Set OpenItem = Application.Inspectors(a).CurrentItem
    If TypeOf OpenItem Is MailItem Then
        If OpenItem.Subject Like "*New*Invoice*" Then
            b = b + 1
            ReDim Preserve arrDraft(1 To b)
            Set arrDraft(b) = OpenItem
        End If
    End If
Next

ReDim Preserve arrAtt(1 To UBound(arrDraft))
ReDim Preserve arrAdd(1 To UBound(arrDraft))

For a = 1 To UBound(arrDraft)
    arrAdd(a) = arrDraft(a).To
    If Not sTraddrUnique Like "*" & arrDraft(a).To & "*" Then _
        sTraddrUnique = sTraddrUnique & IIf(Len(sTraddrUnique) = 0,"","/") & arrDraft(a).To
    Set arrAtt(a) = arrDraft(a).Attachments.Item(1)
Next

arrUnqAdd = Split(sTraddrUnique,"/")

Dim NewMail As MailItem
For a = LBound(arrUnqAdd) To UBound(arrUnqAdd())
    Set NewMail = Application.CreateItem(olMailItem)
    NewMail.To = arrUnqAdd(a)
    For b = LBound(arrAdd) To UBound(arrAdd)
        If arrAdd(b) = arrUnqAdd(a) Then

            '****
            'HERE IS THE PROBLEM
            NewMail.Attachments.Add arrAtt(b) 
            '****

        End If
    Next
    Set NewMail.SendUsingAccount = NewAccount
    NewMail.display
Next

End Sub

解决方法

您可以尝试使用 Type parameter 添加附件作为嵌入项目。我个人在添加 OlAttachmentType.olEmbeddeditem 作为第二个参数后采用您的代码时遇到了运行时错误 438。

还有an example with attaching contact item instead of file from filesystem。