Hi Everyone,
I'm using the below code to send PDFs using outlook.
My outlooks has multiple emails configured, and I need the code to use a specific email address instead of the default one
Any suggestions would be greatly appreciated
Thanks in advance
I'm using the below code to send PDFs using outlook.
My outlooks has multiple emails configured, and I need the code to use a specific email address instead of the default one
Any suggestions would be greatly appreciated
Thanks in advance
VBA Code:
Sub SendEmailWithPDF(bTest As Boolean)
Dim wsM As Worksheet
Dim wsL As Worksheet
Dim wsR As Worksheet
Dim wsS As Worksheet
Dim rngL As Range
Dim rngSN As Range
Dim rngTN As Range
Dim rngPath As Range
Dim c As Range
Dim lSend As Long
Dim lSent As Long
Dim lCount As Long
Dim lTest As Long
Dim lOff As Long
Dim OutApp As Object
Dim OutMail As Object
Dim strSavePath As String
Dim strPathTest As String
Dim strPDFName As String
Dim strSendTo As String
Dim strSubj As String
Dim strBody As String
Dim strMsg As String
Dim strConf As String
On Error GoTo errHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strMsg = "Could not set variables"
Set wsM = wksMenu
Set wsS = wksSet
Set wsL = wksList
Set wsR = wksRpt
Set rngL = wsL.Range("StoreNums")
Set rngSN = wsR.Range("rngSN")
Set rngTN = wsS.Range("rngTN")
Set rngPath = wsS.Range("rngPath")
'test email address
strSendTo = wsS.Range("rngSendTo").Value
lCount = rngL.Cells.Count
'#columns offset for email address
lOff = 3
If bTest = True Then
strConf = "TEST Emails: "
lTest = rngTN.Value
If lTest > 0 Then
lCount = lTest
End If
Else
strConf = "STORE Emails: "
End If
strConf = strConf & lCount _
& " emails will be sent"
If bTest = True Then
If strSendTo = "" Then
MsgBox "Enter a test email address" _
& vbCrLf _
& "and try again."
GoSettings
GoTo exitHandler
Else
strConf = strConf & vbCrLf _
& "to " & strSendTo
End If
End If
strConf = strConf & vbCrLf & vbCrLf
strConf = strConf & "Please confirm: " _
& vbCrLf & _
"Do you want to send the emails?"
lSend = MsgBox(strConf, _
vbQuestion + vbYesNo, "Send Emails")
If lSend = vbYes Then
strSubj = wsS.Range("rngSubj").Value
strBody = wsS.Range("rngBody").Value
strSavePath = rngPath.Value
strMsg = "Could not test Outlook"
On Error Resume Next
Set OutApp = _
GetObject(, "Outlook.Application")
On Error GoTo errHandler
If OutApp Is Nothing Then
MsgBox "Outlook is not open. " _
& vbCrLf _
& "Open Outlook and try again"
GoTo exitHandler
End If
strMsg = "Could not set path" _
& " for PDF save folder"
If Right(strSavePath, 1) <> "\" Then
strSavePath = strSavePath & "\"
End If
If DoesPathExist(strSavePath) Then
'continue code below,
' using strSavePath
Else
MsgBox "The Save folder, " _
& strSavePath _
& vbCrLf & "does not exist." _
& vbCrLf & _
"Files could not be created." _
& vbCrLf & _
"Please select valid folder."
wsS.Activate
rngPath.Activate
GoTo exitHandler
End If
strMsg = "Could not start mail process"
For Each c In rngL
rngSN = c.Value
strMsg = "Could not create PDF for " _
& c.Value
strPDFName = "SalesReport_" _
& c.Value & ".pdf"
If bTest = False Then
strSendTo = c.Offset(0, lOff).Value
End If
wsR.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strSavePath _
& strPDFName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Set OutMail = OutApp.CreateItem(0)
strMsg = "Could not start mail for " _
& c.Value
On Error Resume Next
With OutMail
.To = strSendTo
.CC = ""
.BCC = ""
.Subject = strSubj
.Body = strBody
.Attachments.Add _
strSavePath & strPDFName
.Send
End With
On Error GoTo 0
lSent = lSent + 1
If lSent >= lCount Then Exit For
Next c
Application.ScreenUpdating = True
wsM.Activate
MsgBox "Emails have been sent"
End If
exitHandler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set OutMail = Nothing
Set OutApp = Nothing
Set wsM = Nothing
Set wsS = Nothing
Set wsL = Nothing
Set wsR = Nothing
Set rngL = Nothing
Set rngSN = Nothing
Set rngPath = Nothing
Exit Sub
errHandler:
MsgBox strMsg
Resume exitHandler
End Sub
Last edited by a moderator:
