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

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

要将附件从一封电子邮件拖到另一封电子邮件，您需要 select 所有电子邮件和运行在 selection 上循环然后保存附件然后附加到新邮箱

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

例子

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 以确保您使用的是 Drafts 文件夹

例子

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然后删除文件

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

Move attachment from one draft to another

outlook

vba

email-attachments