Move attachment from one draft to another

Question

Our order system outputs invoices as draft emails. One email is created per invoice, however often this is many emails to the same customer.

For the convenience of our customers, we combine these into one email per customer with multiple invoices attached.

Problem:

When I have various emails open I can manually drag an attachment across from one draft to another.

How can dragging an attachment from one draft email onto another be coded?

I tried using an array of attachment objects (as per my unsolved question here) but that doesn't seem possible.

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

To drag an attachment from one email onto another you will need to select all the emails and run loop on selection then save attachments then attach to the new email

start with simple steps then improve it

Example

---

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

---

You can check the ActiveExplorer to make sure you are using Drafts folder

Example

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

---

You may also wanna check if folder_path exists

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

Or use system temp folder GetSpecialFolder(2).Path then delete files