Send mails & attach doc using VBA

[helios_foster]

Hi there,

I´m using a code that is not working properly. The purpose is to send several emails attaching a pdf doc. Can anyone help me to find out a solution?:

Sub Sendmail()
For i = CInt(Range("B6")) To CInt(Range("B7"))
Dim Email As CDO.Message
Set Email = New CDO.Message
my_email = Range("B2")
password_my_email = Sheets("Pass").Range("C2")

recipient_mails = Range("B" & CStr(i))
copied_mail = Range("B3")
c_c_d = Range("B4")
subject = Range("C" & CStr(i))
Persona = Range("A" & CStr(i))
Message = Range("A10")
sign = Range("C10")
Email.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
Email.Configuration.Fields(cdoSendUsingMethod) = 2
With Email.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = CLng(465)
.Item("http://schemas.microsoft.com/cdo/" & "configuration/smtpauthenticate") = Abs(1)
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = my_email
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
End With
With Email
.To = recipient_mails
.From = my_emails
.Subject = "School" & " - " & Matter & " / " & "Families"
.TextBody = "Dear families," & vbCrLf & vbCrLf & Mensaje & vbCrLf & vbCrLf & sign
.Configuration.Fields.Update

If (Trim(copied_mail) = "") Then
.CC = copied_mail
End If
.AddAttachment (Range("B4").Value

On Error Resume Next
.Send
End With
Next
If Err.Number = 0 Then
MsgBox "Sent email", vbInformation, "Resumen"
Else
MsgBox "Error: " & Err.Description, vbCritical, "Error"
End If

 

[Kenneth Hobson]

Welcome to the forum!

Please past code between code tags or in the code window. Click the <> to open the code window.

Did you prefer CDO over Outlook?

If Outlook, see examples at: https://www.rondebruin.nl/win/section1.htm

If CDO, my function might help.

'http://www.rondebruin.nl/win/s1/cdo.htm
'http://www.learnexcelmacro.com/wp/2011/12/how-to-send-an-email-using-excel-macro-from-gmail-or-yahoo/
'https://www.youtube.com/watch?v=pFl7W8d7d4M
'http://www.blueclaw-db.com/access_email_gmail.htm

'cdo methods and properties or options, those shown by early binding but more detail:
'https://msdn.microsoft.com/en-us/library/ms872547%28EXCHG.65%29.aspx?f=255&MSPPError=-2147217396

'http://www.mrexcel.com/forum/excel-questions/905304-help-cdo.html
Sub Main()
  Dim r As Range, c As Range
  Dim sTo As String
 
  Set r = Worksheets("Sheet1").Range("B7:C25")
  For Each c In r
    With c
      If InStr(.Value2, "@") <> 0 Then sTo = sTo & "," & .Value2
    End With
  Next c
 
  If sTo = "" Then
    MsgBox sTo, vbCritical, "Ending Macro - Missing email(s)"
    Exit Sub
  End If
 
  sTo = Right(sTo, Len(sTo) - 1)
 
  Gmail "ken@gmail.com", "Ken", _
    "Subject", _
    "Body", _
    sTo, _
    "noone@nowhere.com"
End Sub


Sub Test_Gmail()
  Gmail "ken@gmail.com", "ken", "Hello World!", _
    "This is a test using CDO to send Gmail with an attachement.", _
    "khobson@somewhere.org", "uknowwho@nowwhere.com", _
    "x:\test\test.xlsm"
End Sub

' http://www.blueclaw-db.com/access_email_gmail.htm
' http://msdn.microsoft.com/en-us/library/ms872547%28EXCHG.65%29.aspx
' Add CDO reference for early binding method
'  Tools > References > Microsoft CDO for Windows 2000 Library
'    c:\windows\system32\cdosys.dll
' http://www.rondebruin.nl/cdo.htm  'Other cdo tips for cdo to Outlook from Excel

'CDO to gmail requires lowering your security:
'https://myaccount.google.com/security#connectedapps
'at the end set, Allow less secure apps: ON

Function Gmail(sendUsername As String, sendPassword As String, subject As String, _
  textBody As String, sendTo As String, sendFrom As String, _
  Optional sAttachment As String = "")
 
  Dim cdomsg As New CDO.Message  'early binding method
  'set cdomsg=new CDO.Message 'early binding only
  'Dim cdomsg As Object 'late binding method
  Set cdomsg = CreateObject("CDO.message")  'late binding method or early binding
  With cdomsg.Configuration.Fields
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
    .Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 25  '25 or 587
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sendUsername
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sendPassword
    .Update
  End With
  ' build email parts
  With cdomsg
    .To = sendTo
    .From = sendFrom
    .subject = subject
    .textBody = textBody
    '.BCC
    '.CC
    '.ReplyTo = sendFrom
    '.HTMLBody
    '.HTMLBodyPart
    If Dir(sAttachment) = "" Then sAttachment = ""
    If sAttachment <> "" Then .AddAttachment (sAttachment)
    .Send
  End With
  Set cdomsg = Nothing
End Function