Help making VBA Gmail mail merge code work

R

robgoldstein

Board Regular
Joined
Oct 26, 2013
Messages
165
Office Version
  1. 2019
Platform
  1. Windows
I am adapting some code to make a mail merge work directly from Excel using a Gmail address, but I am having some problems. Any help would certainly be appreciated.
I want this to send an email to every column that does not equal "not scheduled this week" in column "I"
my info is in the following columns

First Name: C
Team: H
Game Date: I
Game Location: J
Game time: K
Field:L
Email: M


Code: 
Sub SendWith_SMTP_Gmail_To_Parent()
'Works On Windows (Not Mac). Mac Users Should Use Zapier Integration
'Created by Randy Austin www.ExcelForFreelancers.com
Dim EmailMsg, EmailConf As Object
Dim Subj, Mess, Json, URL, LastName, FirstName, Email, Attach As String
Dim ContactRow, LastRow, SentCounter As Long
Dim EmailFields As Variant
Set EmailMsg = CreateObject("CDO.Message") 'CDO (Collaboration Data Objects) -Make sure you have the 'CDO For Windows' Library Selected
Set EmailConf = CreateObject("CDO.Configuration")
    EmailConf.Load -1    ' Set CDO Source Defaults
     Set EmailFields = EmailConf.Fields
     With EmailFields
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Robgoldstein@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Update
     End With
With Sheet1
    
    
    LastRow = .Range("E999").End(xlUp).Row 'Get Last Row Of Table
    
    For ContactRow = 2 To 55
        Subj = .Range("B53").Value 'Email Subject
        Mess = .Range("B54").Value 'Email Message
        If .Range("I" & ContactRow).Value <> "not scheculed this week" Then GoTo NextRow
        FirstName = .Range("C" & ContactRow).Value
        Date = .Range("I" & ContactRow).Value
        Team = .Range("H" & ContactRow).Value
        Location = .Range("J" & ContactRow).Value
        Time = .Range("K" & ContactRow).Value
        Field = .Range("L" & ContactRow).Value
        Email = .Range("M" & ContactRow).Value
        Subj = Replace(Replace(Subj, "#date", Date), "#LastName#", LastName)
         Mess = Replace(Replace(Mess, "#FirstName#", FirstName), "#LastName#", LastName)
        Mess = Replace(Replace(Mess, "#FirstName#", FirstName), "#team#", Team),"#date#", Date), "#location#",Location), "#gametime#",Time"), "#field#",Field)
       
        With EmailMsg
            Set .Configuration = EmailConf
            .To = Email
            .CC = ""
            .BCC = ""
            .From = """SC Toronto 2011 Boys Winter Soccer"" <robgoldstein@gmail.com>"
            .Subject = Subj
             If Attach <> Empty Then .AddAttachment Attach
            .TextBody = Mess
            .Send
        End With
        SentCounter = SentCounter + 1
NextRow:
    Next ContactRow
    
      'Cleanup
    Set EmailMsg = Nothing
    Set EmailConf = Nothing
    Set EmailFields = Nothing
End With
MsgBox SentCounter & " Emails have been sent"
End Sub
</robgoldstein@gmail.com>
 
Last edited:
Sort by date Sort by votes
I just edited the code in post 7, so you'll need to copy it again and replace the code you pasted last time.
 
Upvote 0

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Run-time error 13
Type Mismatch.

when debug, i highlights this line
Date = .Range("I" & ContactRow).Value
 
Upvote 0
Why are you trying to alter your system date? :)
 
Upvote 0
Date is a system function, not a variable. You should declare your own variable and make sure the cell actually contains a date first.
 
Upvote 0
OK. Thanks. I Have changed date to gamedate


Code: 
Sub SendWith_SMTP_Gmail_To_Parent()
'Works On Windows (Not Mac). Mac Users Should Use Zapier Integration
'Created by Randy Austin www.ExcelForFreelancers.com
Dim EmailMsg, EmailConf As Object
Dim Subj, Mess, Json, URL, LastName, FirstName, Email, Attach As String
Dim ContactRow, LastRow, SentCounter As Long
Dim EmailFields As Variant
Set EmailMsg = CreateObject("CDO.Message") 'CDO (Collaboration Data Objects) -Make sure you have the 'CDO For Windows' Library Selected
Set EmailConf = CreateObject("CDO.Configuration")
    EmailConf.Load -1    ' Set CDO Source Defaults
     Set EmailFields = EmailConf.Fields
     With EmailFields
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "sctoronto2011boys@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "2011soccer"
        .Update
     End With
With Sheet1
    
    
    LastRow = .Range("E999").End(xlUp).Row 'Get Last Row Of Table
    
    For ContactRow = 2 To 57
        Subj = .Range("B53").Value 'Email Subject
        Mess = .Range("B54").Value 'Email Message
        If .Range("I" & ContactRow).Value = "not scheduled this week" Then GoTo NextRow
        FirstName = .Range("C" & ContactRow).Value
        GameDate = .Range("I" & ContactRow).Value
        Team = .Range("H" & ContactRow).Value
        Location = .Range("J" & ContactRow).Value
        Time = .Range("K" & ContactRow).Value
        Field = .Range("L" & ContactRow).Value
        Email = .Range("M" & ContactRow).Value
        Subj = Replace(Replace(Subj, "#gamedate", GameDate), "#LastName#", LastName)
         Mess = Replace(Replace(Mess, "#FirstName#", FirstName), "#LastName#", LastName)
         Mess = Replace(Replace(Mess, "#FirstName#", FirstName), "#team#", Team),"#gamedate#", gameDate), "#location#",Location), "#gametime#",Time"), "#field#",Field)
       
        With EmailMsg
            Set .Configuration = EmailConf
            .To = Email
            .CC = ""
            .BCC = ""
            .From = """SC Toronto 2011 Boys Winter Soccer"" <Robgoldstein@gmail.com>"
            .Subject = Subj
             If Attach <> Empty Then .AddAttachment Attach
            .TextBody = Mess
            .Send
        End With
        SentCounter = SentCounter + 1
NextRow:
    Next ContactRow
    
      'Cleanup
    Set EmailMsg = Nothing
    Set EmailConf = Nothing
    Set EmailFields = Nothing
End With
MsgBox SentCounter & " Emails have been sent"
End Sub
 
Upvote 0
still no emails sent.

Syntax error on
Code: 
Mess = Replace(Replace(Mess, "#FirstName#", FirstName), "#team#", Team),"#gamedate#", gameDate), "#location#",Location), "#gametime#",Time"), "#field#",Field)
 
Upvote 0
That's not in my code. Compare mine to yours - you're trying to do 6 Replace operations with only 2 Replace functions.
 
Upvote 0
OMG. I am so sorry. I copied your code into a new macro to keep it seperate and sent the wrong code.

Error I am getting now is
Run-Time Error -'2147220979 (8004020d)':
At least one of the From or Sender fields is required, and neither was found.
When i hit debug it highlights the "send" field.

Code: 
Sub SendWith_SMTP_Gmail_To_Parent2()
'Works On Windows (Not Mac). Mac Users Should Use Zapier Integration
'Created by Randy Austin www.ExcelForFreelancers.com
   Dim Subj, Mess, Json, URL, LastName, FirstName, Email, Attach As String
   Dim ContactRow, LastRow, SentCounter As Long
   With Sheet1


      LastRow = .Range("E999").End(xlUp).Row   'Get Last Row Of Table


      For ContactRow = 2 To 55


         Subj = .Range("B53").Value   'Email Subject
         Mess = .Range("B54").Value   'Email Message
         If .Range("I" & ContactRow).Value <> "not scheduled this week" Then
         FirstName = .Range("C" & ContactRow).Value
         GameDate = .Range("I" & ContactRow).Value
         Team = .Range("H" & ContactRow).Value
         Location = .Range("J" & ContactRow).Value
         gameTime = .Range("K" & ContactRow).Value
         Field = .Range("L" & ContactRow).Value
         Email = .Range("M" & ContactRow).Value
         Subj = Replace(Replace(Subj, "#date", Date), "#LastName#", LastName)
         Mess = Replace(Replace(Mess, "#FirstName#", FirstName), "#LastName#", LastName)
         Mess = Replace(Replace(Mess, "#team#", Team), "#gamedate#", Date)
         Mess = Replace(Replace(Replace(Mess, "#location#", Location), "#gametime#", gameTime), "#field#", Field)




         Dim EmailMsg As Object
         Set EmailMsg = NewCDOMessage
         With EmailMsg
            .To = Email
            .CC = ""
            .BCC = ""
            .From = """SC Toronto 2011 Boys Winter Soccer"" "
            .Subject = Subj
            If Attach <> Empty Then .AddAttachment Attach
            .TextBody = Mess
            .Send
         End With
         SentCounter = SentCounter + 1
       End If
      Next ContactRow


      'Cleanup
      Set EmailMsg = Nothing
      Set EmailConf = Nothing
      Set EmailFields = Nothing
   End With
   MsgBox SentCounter & " Emails have been sent"
End Sub
Function NewCDOMessage() As Object
   Dim EmailConf As Object
   Dim EmailFields As Variant
   Set NewCDOMessage = CreateObject("CDO.Message")   'CDO (Collaboration Data Objects) -Make sure you have the 'CDO For Windows' Library Selected
   Set EmailConf = CreateObject("CDO.Configuration")
   EmailConf.Load -1    ' Set CDO Source Defaults
   Set EmailFields = EmailConf.Fields
   With EmailFields
      .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
      .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
      .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
      .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
      .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
      .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "sctoronto2011boys@gmail.com"
      .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "2011soccer"
      .Update
   End With
   Set NewCDOMessage.Configuration = EmailConf


End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA to email multiple ranges on a sheet.
Replies
0
Views
246
shophoney
S
T
  • Question
vba to send calendar appointments rather then emails
Replies
1
Views
435
Tej92
T
S
  • Question
Email with VBA without outlook
Replies
4
Views
887
Shloime
S
T
  • Solved
Sending emails using VBA without outlook
Replies
1
Views
4K
Tej92
T
R
  • Solved
Sending gmail email through Excel (VBA)
Replies
6
Views
4K
kavemankev
K

Forum statistics

Threads
1,214,970
Messages
6,122,514
Members
449,088
Latest member
RandomExceller01

Share this page

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