[Excel VBA]Parse & Send an email multiple worksheets to multiple recipients using Gmail

Hi Friends,

I'm having a trouble in these 3 codes. I'd like to integrate the code of Dinesh Takyar and the code from Rondebruin and the code from an attachment but I'm stuck in incorporating these codes into one.

What I want to happen is that:[LIST=1][*]I'll be able to send emails to different recipients with different worksheets

• For example: in the Master File, named, "Outdated", the recipient, 21 QUEEN REALTY & BROKERAGE has 2 names in the supplier column BUT if you check their rows it has different values.
  What will happen is that this will be put in one worksheet (parsing the data). The same will happen with the others in the Supplier column).
  After this will be put in one worksheet, this worksheet will be sent out to the email of 21 QUEEN REALTY & BROKERAGE ie. in the last column BUT in the column of email addresses (Column O) it is the same like the Supplier column wherein it is duplicated or it just don't occur once but many times.
  Lastly, the excel worksheet will be sent as an attachment to the recipient.
  
• In the sample attachment, you will see the tab, SalesRpt. That sample template is what I want to use with the message I want to tell to the recipient and the data for the worksheet(s).
  

• The recipient may be one or many. The same goes for the sender, it may be one or many.
  • There will be like a Menu that can be setup the sender(s)' email address(es) or one sender then use either BCC or CC. Also the content, subject will be setup in the same menu.
    Just like the code in the attachment: emailtestfile 2.xlsm.
  • There will be a copy of the excel worksheet on the folder I want to use (able to browse just like when saving any file, we will be prompt on where to save the file).

These are the problems I encountered when I setup the file:

• The file keeps on crashing that's why I need help so I am now starting from scratch.
• I tried on integrating the 3 codes but I'm having a hard time because one code is that the subject, body, sender and recipient cannot be edited because it is inside the module, it is not linked to any cell or range. The other one is linked to outlook and the attachment(s) are in pdf. I tried to change the xltypePDF to xltypeXLS or xltypeXLSX but to no avail, it is not working. The other one, I tried using the codes' attachment: Attachment 389737 but I'm having a hard time in changing it even the template when it is being sent out.

These are the codes that I find useful for the output that I want:
From Dinesh Takyar:

Sub send_email_via_Gmail()
Dim myMail As CDO.Message

Set myMail = New CDO.Message

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpusessl”) = True

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpauthenticate”) = 1

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserver”) = “smtp.gmail.com”

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserverport”) = 25

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendusing”) = 2

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendusername”) = “takyardinesh@gmail.com”

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendpassword”) = “password”

myMail.Configuration.Fields.Update

With myMail
.Subject = “Test Email from Dr. Takyar”
.From = “takyardinesh@gmail.com”
.To = “takyar@hotmail.com; takyar@exceltrainingvideos.com”
.CC = “dinesh.takyar@gmail.com”
.BCC = “”
.TextBody = “Good morning!”
.AddAttachment “C:\Users\takyar\Desktop\email-via-gmail.txt”
End With
On Error Resume Next
myMail.Send
‘MsgBox(“Mail has been sent”)
Set myMail = Nothing

End Sub

Using Yahoo with VBA:
Sub email_using_Yahoo_VBA()

Dim myMail As CDO.Message

Set myMail = New CDO.Message

‘Enable SSL Authentication
myMail.Configuration.Fields.Item _
(“http://schemas.microsoft.com/cdo/configuration/smtpusessl”) = True

‘SMTP authentication Enabled

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpauthenticate”) = 1

‘Set the SMTP server and port details

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserver”) = “smtp.mail.yahoo.com”

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserverport”) = 465

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendusing”) = 2

‘Set your username and password for your Yahoo Account

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendusername”) = “fccin2000@yahoo.com”

myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendpassword”) = “password”

‘Update all configuration fields
myMail.Configuration.Fields.Update

‘Set the email properties

With myMail
.Subject = “Test Mail from Dr. takyar”
.From = “fccin2000@yahoo.com”
.To = “takyardinesh@gmail.com; takyar@exceltrainingvideos.com”
.CC = “dinesh.takyar@gmail.com”
.BCC = “”
.TextBody = “Welcome to MS Excel Training!”
End With

myMail.Send
MsgBox (“Mail sent”)

‘Set myMail Variable to Nothing to free memory
Set myMail = Nothing

End Sub

Code from Rondebruin:

Sub Mail_sheets()
    Dim MyArr As Variant
    Dim last As Long
    Dim shname As Long
    Dim a As Integer
    Dim Arr() As String
    Dim N As Integer
    Dim strdate As String
    For a = 1 To 253 Step 3
        If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then 
            Exit Sub
        End
        Application.ScreenUpdating = False
        last = ThisWorkbook.Sheets("mail").Cells(Rows.Count, _
            a).End(xlUp).Row
        N = 0
        For shname = 1 To last
            N = N + 1
            ReDim Preserve Arr(1 To N)
            Arr(N) = ThisWorkbook.Sheets("mail").Cells(shname, a).Value
        Next shname
        ThisWorkbook.Sheets(Arr).Copy
        strdate = Format(Date, "dd-mm-yy") & " " & _
            Format(Time, "h-mm-ss")
        ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
            & " " & strdate & ".xls"
        With ThisWorkbook.Sheets("mail")
            MyArr = .Range(.Cells(1, a + 1), .Cells(Rows.Count, _
                a + 1).End(xlUp))
        End With
        ActiveWorkbook.SendMail MyArr, ThisWorkbook.Sheets("mail").Cells(1, a + 2).Value
        ActiveWorkbook.ChangeFileAccess xlReadOnly
        Kill ActiveWorkbook.FullName
        ActiveWorkbook.Close False
        Application.ScreenUpdating = True
    Next a
End Sub

Code from the attachment: emailtestfile 2.xlsm
In Module: modFiles

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

In Module: modNav

Option Explicit

Sub GoMenu()
On Error Resume Next
wksMenu.Activate
End Sub


Sub GoSettings()
On Error Resume Next
With wksSet
   .Activate
   .Range("rngSubj").Activate
End With
End Sub

Please see my file in this link: https://www.dropbox.com/s/lnsbdxo9di...mple.xlsm?dl=0