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

dylanrose

New Member
Joined
Mar 29, 2014
Messages
6
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

    • 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:
    Code:
    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:
    Code:
    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
    Code:
    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
    Code:
    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
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

Forum statistics

Threads
1,213,549
Messages
6,114,264
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top