Remove confirmation box from VBA

[canadabeisbol]

Hi all - I have a VBA I downloaded from Contexture (attached) which sends a PDF of one of the excel sheets to a list of email addresses on another sheet. It's quite cool actually and works great. I'm wondering however if it's possible to remove the text in the VBA that requires a box to pop up when you click "Send Emails" which requires you to then click "Yes". I'd like the emails to just send when the orange "Send Emails" button is clicked. Thank you very very much for anybody who is able to help.

send emails box.PNG

Here is the VBA text:
-----


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"
If bTest = False Then
strSendTo = c.Offset(0, 3).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

[YasserKhalil]

Hello
Just comment these lines

Please Login or Register  to view this content.

[canadabeisbol]

I'm sorry I just don't understand. Are you able to paste the whole thing so I can see what it should look like? Thank you so so much!

[YasserKhalil]

This your code and I just commented out the lines I referred in the last post

Please Login or Register  to view this content.

[canadabeisbol]

Wow you are incredible. Thank you so much sir! Never would have got that.

[torachan]

if you place a single apostrophe in front of each of the first nine lines below.
then add the extra two lines below that, this should override the messagebox and continue code without interruption.

Please Login or Register  to view this content.

[YasserKhalil]

You're welcome. Glad I can offer little help.
Please mark the thread as solved