Help making VBA Gmail mail merge code work

[robgoldstein]

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

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>

 

[RoryA]

Firstly, your code says "scheculed " rather than "scheduled". Also, it only sends the email if the value is "not scheduled this week", which seems to be the opposite of what you wanted.

 

[robgoldstein]

Thanks RoryA,
I do actually want to send an email to every row that does not have the text "not scheduled this week" in column "I" what do I need to do to change that?. Either way, it was not sending the email to those lines either.
that typo was just text, and I have now fixed it, but I don't think that would cause the problem because I had the same typo in the sheet.

 

[RoryA]

This line:

If .Range("I" & ContactRow).Value <> "not scheculed this week" Then GoTo NextRow

should be:

If .Range("I" & ContactRow).Value = "not scheduled this week" Then GoTo NextRow

since you want to skip rows where that is the value. I suspect you also need to move the lines that create the message inside your For loop.

 

[robgoldstein]

Thanks Rory,
One problem crossed off the list. but not working yet.

 

[RoryA]

Did you do the last bit?

 

[RoryA]

Untested as work block this sort of thing, but try:

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 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
         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, "#team#", Team), "#date#", Date)
         Mess = Replace(Replace(Replace(Mess, "#location#", Location), "#gametime#", Time), "#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") = "Robgoldstein@gmail.com"
      .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
      .Update
   End With
   Set NewCDOMessage.Configuration = EmailConf

End Function

 

[robgoldstein]

Still getting a 0 emails sent message after running.

 

[RoryA]

I'd forgotten to change your criteria. Please try the amended code version above.

 

[robgoldstein]

Rory, I am not sure what code version you are referring to. I copied your code into a new module and ran it that way.