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

[dylanrose]

This is the a cross link from: [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 Rondebruinand the code from anattachment but I'm stuck in incorporating these codes into one.What I want to happen is that:

1. I'll be able to send emails to different recipients with different worksheets

1. 
   
   • 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