Hello everyone,
I'm trying to send an email with multiple attachments via VBA and outlook. The code I have works if I specify the path to one
sPathFile = "C:\temp\log.txt"
I can have upwards of 50 files "eg. pdf, doc or text" in the folder at any one time when I decide to send it.
I also have batch file (movefiles.bat) in the same folder that I would like to execute when the attachment is send out.
I am also curious if the code can monitor c:\temp folder and send out the files when it becomes available.
Help on this is greatly appreciated.
I hope I have provided sufficient information to see if this is feasible. Thank you.
Sub SendEmail()
On Error GoTo Err_SendEmail Dim sTo As String
Dim sCC As String
Dim sSubject As String
Dim sBody As String
Dim sAttachmentList As String
Dim sReplyRecipient As String
Dim sPathFile As String
sPathFile = "C:\temp\log.txt"
' You must key a semicolon between each email name.{ emailaddress; emailaddress}
sTo = "emailaddress"
sCC = "emailaddress"
sReplyRecipient = "emailaddress"
sSubject = "Important Email"
sBody = sBody & "Please read then destroy this important email!"
sAttachmentList = sPathFile
' send email with a file attachment
Call SetupOutlookEmail(sTo, sCC, sReplyRecipient, sSubject, sBody, sAttachmentList)
' send email without a file attachment
'Call SetupOutlookEmail(sTo, sCC, sReplyRecipient, sSubject, sBody)
Exit_SendEmail:
Exit Sub
Err_SendEmail:
' Cannot find this file. Verify the path and file name are correct.
If Err.Number = -2147024894 Then
MsgBox "Email message was not sent. Please verify the file exists " & sPathFile & " before attempting to resend the email.", vbCritical, "Invalid File Attachment"
Exit Sub
' Outlook does not recognize one or more names.
ElseIf Err.Number = -2147467259 Then
MsgBox "Email message was not sent. Please verify all user names and email addresses are valid before attempting to resend the email.", vbCritical, "Invalid Email Name"
Exit Sub
Else
MsgBox Err.Number & " - " & Err.Description, vbCritical, "SendEmail()"
Resume Exit_SendEmail
End If
End Sub
Public Function SetupOutlookEmail(ByVal sTo As String, ByVal sCC As String, ByVal sReplyRecipient As String, ByVal sSubject As String, ByVal sBody As String, ParamArray sAttachmentList() As Variant) As Boolean
On Error GoTo Err_SetupOutlookEmail
Dim objOLApp As Object
Dim outItem As Object
Dim outFolder As Object
Dim DestFolder As Object
Dim outNameSpace As Object
Dim lngAttachment As Long
Set objOLApp = CreateObject("Outlook.Application")
Set outNameSpace = objOLApp.GetNamespace("MAPI")
Set outFolder = outNameSpace.GetDefaultFolder(6)
Set outItem = objOLApp.CreateItem(0)
outItem.To = sTo
outItem.CC = sCC
outItem.Subject = sSubject
outItem.HTMLBody = sBody
outItem.ReplyRecipients.Add sReplyRecipient
outItem.ReadReceiptRequested = False
With outItem.Attachments
For lngAttachment = LBound(sAttachmentList) To UBound(sAttachmentList)
.Add sAttachmentList(lngAttachment)
Next lngAttachment
End With
'outItem.Send
' setup and open email in edit mode instead of sending the email
outItem.Display
SetupOutlookEmail = True
Exit_SetupOutlookEmail:
On Error Resume Next
Set outItem = Nothing
Set outFolder = Nothing
Set outNameSpace = Nothing
Set objOLApp = Nothing
Exit Function
Err_SetupOutlookEmail:
' User stopped Outlook from sending email.
If Err.Number = 287 Then
MsgBox "User aborted email.", vbInformation, "Email Cancelled"
Resume Exit_SetupOutlookEmail
Else
MsgBox Err.Number & " - " & Err.Description, vbCritical, "SetupOutlookEmail()"
Resume Exit_SetupOutlookEmail
End If
End Function
FYI I have basic knowledge on coding so comments on the code are greatly appreciated.