Create one email and attach all attachments from selected emails

[ashleyuk1984]

Hi,
I have a daily task to complete which isn't very hard or time consuming, but it could be streamlined to make it extremely easy and quick.

I get multiple emails sent to me throughout the evening and night, and I see them when I turn the computer back on the next morning.
These emails have an attachment. There is just one PDF file on each email.

I have to forward these attachments onto our customer... However, they only want one email sent.
So as a 'manual' process it's not too bad, it's just takes maybe about a minute or so to go through the emails and drag all of the attachments from the nightly mails to the newly created email ready for sending.

I would like to streamline this by using VBA.

This is what I would like to ideally happen...
I would highlight each of the new emails, and press a button on my ribbon (I know how to create buttons and assign them to macros).

Once I push the button, the macro would create a new email window for me and run through my selection of emails and take each of the PDF files from my selection and attach them to my new email window.

I'm not clued up on Outlook based VBA. :(

I imagine I'll require something along the lines of:



Dim atch As Outlook.Attachment

For Each atch In Application.ActiveExplorer.Selection


But as far as taking attachments from several different emails, and placing them onto one email - I have no idea?

Any help with this would be greatly appreciated.
Thanks

[gmayor]

You can't simply copy attachments from one message to another in VBA. You must save them then attach them to the outgoing message. The following will do that, saving to the temp folder then attaching the messages, before deleting them. Change the recipeint e-mail address, subject and text of olOutmail as required.

Option Explicit
Sub CollateAttachments()
Dim olItem As Outlook.MailItem
Dim olOutmail As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Set olOutmail = Application.CreateItem(0)
With olOutmail
.To = "someone@somewhere.com"
.Subject = "Today's message attachments"
.BodyFormat = olFormatHTML
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = "Please find attached pdf files for " & Format(Date, "Long Date") & Chr(46)
For Each olItem In Application.ActiveExplorer.Selection
CopyAttachments olItem, olOutmail
Next olItem
.Display 'This line is required
'.Send 'Restore after testing
End With
lbl_Exit:
Exit Sub
End Sub

Private Sub CopyAttachments(olSource As Outlook.MailItem, olTarget As Outlook.MailItem)
Dim fso As Object
Dim fld As Object
Dim olAtt As Outlook.Attachment
Dim strfName As String
Dim strPath As String
Dim strExt As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetSpecialFolder(2)
strPath = fld.Path & "\"
For Each olAtt In olSource.Attachments
strExt = Mid(olAtt.FileName, InStrRev(olAtt.FileName, Chr(46)) + 1)
If LCase(strExt) = "pdf" Then
strfName = strPath & olAtt.FileName
olAtt.SaveAsFile strfName
olTarget.Attachments.Add strfName, , , olAtt.DisplayName
fso.DeleteFile strfName
End If
Next
lbl_Exit:
Set fld = Nothing
Set fso = Nothing
Exit Sub
End Sub

[ashleyuk1984]

That is brilliant Graham, thanks a lot!

I was investigating this more last night, and it became apparent that I would have to save the files first, and then attach them to the email...
So I started looking for two macros... One to save the attachments to a local folder, and then one to attach all attachments from a folder to a new email.

I came across two links.

http://www.vboffice.net/en/developers/save-multiple-attachments-to-file-system
http://www.vboffice.net/en/developers/send-all-files-of-a-folder

I began to combine the two macros into one subroutine, and then I got notified of an email from VBAExpress. (your reply) :)

Thank you very much!