将附件从一个草稿移到另一个草稿

Question

我们的订单系统将发票输出为草稿电子邮件。每张发票会创建一封电子邮件，但通常这是发送给同一客户的多封电子邮件。

为了方便我们的客户，我们将这些信息合并为每位客户一封电子邮件，并附上多张发票。

问题：

当我打开各种电子邮件时，我可以手动将附件从一个草稿拖到另一个草稿。

如何将附件从一封草稿电子邮件拖到另一封电子邮件上？

我尝试使用附件对象数组（根据我未解决的问题 here），但这似乎不可能。

Sub AmalgInv()

Dim MyAccount As Account
'section here to set the MyAccount variable, not relevant to this question.

Dim OpenItem As Object
Dim arrDraft() As MailItem

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
'ArrDraft now only contains relevant (invoice) drafts not anything else

Dim arrUnqAdd() As String       'array of unique addresses
Dim strAddrUnique As String     'list of unique email addresses
Dim strAddrNonUnique As String  'list of duplicated email addresses

ReDim Preserve arrAdd(1 To UBound(arrDraft))

For a = 1 To UBound(arrDraft)
    If Not strAddrUnique Like "*" & arrDraft(a).To & "*" Then
        strAddrUnique = strAddrUnique & IIf(Len(strAddrUnique) = 0, "", "/") & arrDraft(a).To
    Else
        strAddrNonUnique = strAddrNonUnique & IIf(Len(strAddrNonUnique) = 0, "", " / ") & arrDraft(a).To
    End If
    
Next

arrUnqAdd = Split(strAddrUnique, "/")
'One option I considered involved creating a similar array of non-unique email addresses
'Hence adding slashes into strAddrNonUnique as well

Dim NewMail As MailItem
For a = LBound(arrUnqAdd) To UBound(arrUnqAdd())
    If Not strAddrNonUnique Like "*" & arrUnqAdd(a) & "*" Then
        'Only one email for this customer/address
        For b = LBound(arrDraft) To UBound(arrDraft)
            If arrDraft(b).To = arrUnqAdd(a) Then
                Set arrDraft(b).SendUsingAccount = MyAccount
                arrDraft(b).Send
                Exit For
            End If
        Next
    Else
        'Multiple emails for this address.
        'This is the bit I need advice on.
        'Tried creating a new email for each and then deleting the leftover ones;
        Set NewMail = Application.CreateItem(olMailItem)
        NewMail.To = arrUnqAdd(a)
        For b = LBound(arrDraft) To UBound(arrDraft)
            If arrDraft(b).To = arrUnqAdd(a) Then
                'transfer that email's attachments across to 'NewMail'
                'close and delete arrDraft(b) - not coded in because the above isn't working yet.
            End If
        Next
        Set NewMail.SendUsingAccount = MyAccount
        NewMail.Display
        'NewMail.Send
Next

End Sub

Answer 1

要将附件从一封电子邮件拖到另一封电子邮件，您需要选择所有电子邮件并在选择时运行循环，然后保存附件，然后附加到新电子邮件

从简单的步骤开始，然后改进它

例子

---

Option Explicit
Public Sub Example()
    Dim Selection_Items As Outlook.Selection
    Set Selection_Items = Outlook.Application.ActiveExplorer.Selection
    
    Debug.Print Selection_Items.Count & " items in Selection" 'print on immed win        
        
    Dim Folder_Path As String
    Folder_Path = "D:\Temp"
    
    Dim New_Email As Outlook.MailItem
    Set New_Email = Outlook.Application.CreateItem(olMailItem)
    
    Dim i As Long
    Dim Item As Outlook.MailItem
    Dim Attachment As Outlook.Attachment
    Dim Attachment_Path   As String
    
    For i = Selection_Items.Count To 1 Step -1
        DoEvents
        
        Debug.Print Selection_Items(i).Subject
        
        Set Item = Selection_Items(i)
        
        For Each Attachment In Item.Attachments
            Debug.Print Attachment.FileName
            
            Attachment_Path = Folder_Path & "\" & Attachment.FileName
            Attachment.SaveAsFile Attachment_Path
            New_Email.Attachments.Add (Attachment_Path)

        Next
        
    Next
    
    New_Email.Display
    
End Sub

---

您可以检查ActiveExplorer 以确保您使用的是草稿文件夹

例子

If Not Outlook.Application.ActiveExplorer.CurrentFolder.Name = "Drafts" Then Exit Sub

---

您可能还想检查folder_path 是否存在

Folder_Path = "D:\Temp"
CreateDir Folder_Path

---

Private Function CreateDir(FldrPath As String)
    Dim Elm As Variant
    Dim CheckPath As String

    CheckPath = ""
    For Each Elm In Split(FldrPath, "\")
        CheckPath = CheckPath & Elm & "\"
        
        If Len(Dir(CheckPath, vbDirectory)) = 0 Then
            MkDir CheckPath
            Debug.Print CheckPath & " Folder Created"
        End If
        
        Debug.Print CheckPath & " Folder Exist"
    Next
End Function

或者使用系统临时文件夹GetSpecialFolder(2).Path然后删除文件