I receive automated emails that have attachments. Different customers are identified by the subject line.
I drag and drop the attachments into a new email and send it to the appropriate customer.
I want to automate this process so that I can click and automatically generate the emails for each customer with the appropriate attachments included.
I scraped together some things I found on the internet. It works for one customer.
It loops through a sub-folder (Test2) and copies each attachment to a local file on my machine (test2), then it generates an email and attaches all the items from the local folder to the new email and sends the email to X.
Send()
SaveEmailAttachmentsToFolder "Test Folder2", "pdf", "C:\Users\UserName\Desktop\test2"
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, destFolder As String)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim i As Integer
Dim wsh As Object
Dim fs As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
If destFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.item("mydocuments")
destFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(destFolder) Then
fs.CreateFolder destFolder
End If
End If
If Right(destFolder, 1) <> "\" Then
destFolder = destFolder & "\"
End If
' Check each message for attachments and extensions
For Each item In SubFolder.Items
For Each Atmt In item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = destFolder & item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next item
' Show this message when Finished
If i > 0 Then
MsgBox "You can find the files here : " _
& destFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
''This portion generates the email
'' pulls the attachments from local test 2 folder
'' sends email to specified email address
Dim mess_body As String, StrFile As String, StrPath As String
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
'~~> Change path here
StrPath = "C:\Users\KTucker\Desktop\test2\"
With MailOutLook
.BodyFormat = olFormatRichText
.To = "[email protected]"
.Subject = "This an email subject"
.HTMLBody = "This is an email body"
'~~> *.* for all files
StrFile = Dir(StrPath + "*.*")
Do While Len(StrFile) > 0
.Attachments.Add StrPath & StrFile
StrFile = Dir
Loop
'.DeleteAfterSubmit = True
.Send
End With
MsgBox "Reports have been sent", vbOKOnly
'Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
The top half copies all of the attachments from the 'Test Folder2' sub-folder, then saves it to 'Desktop/Test2' folder.
The second half generates a new email, pulls all the documents in the local Test2 file and attaches it to the new email, then sends it to the specific address.
What code could I add in the top half that would parse the same sub-folder (Test Folder2) and save all attachments from emails with one subject line to one local folder, and all attachments from emails with a different subject line to another folder?
