Option Explicit
Sub SendEmailTest()
SendEmailWithPDF (True)
End Sub
Sub SendEmailStores()
SendEmailWithPDF (False)
End Sub
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 rngPath As Range
Dim c As Range
Dim lSend As Long
Dim lCount 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 rngPath = wsS.Range("rngPath")
lCount = rngSN.Cells.Count
If bTest = True Then
strConf = "TEST Emails: "
Else
strConf = "STORE Emails: "
End If
strConf = strConf & wsS.Range("rngCountMail").Value
strConf = strConf & vbCrLf & vbCrLf
strConf = strConf & "Please confirm: 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
strSendTo = wsS.Range("rngSendTo").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, 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 a 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"
'strPDFName = "c.Value_" & "SalesReport_" & ".pdf"
If bTest = False Then
strSendTo = c.Offset(0, 300).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 process 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
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
Function DoesPathExist(myPath As String) As Boolean
Dim TestStr As String
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
TestStr = ""
On Error Resume Next
TestStr = Dir(myPath & "nul")
On Error GoTo 0
DoesPathExist = CBool(TestStr <> "")
End Function
Sub GetFolderFilesPDF()
Dim rngPath As Range
On Error Resume Next
Set rngPath = wksSet.Range("rngPath")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
rngPath.Value = .SelectedItems(1)
End If
End With
End Sub
Sub TestOutlook()
Dim oOutlook As Object
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If oOutlook Is Nothing Then
MsgBox "Outlook is not open, open Outlook and try again"
Else
'Call NameOfYourMailMacro
End If
End Sub
