Gmail With Excel File as Attachment

[motabrasil]

Hello VBA Masters
I have a big challenge today. I need to send a group of emails using GMail once a week.
I have a list of names, email address, cc and email body are on my master file. And, each email from my list needs to attach a file that has the same Name from master file. All files are saved in the same folder where the macro will be saved. I was checking others threads with the same issue but they didn't succeed.
Any idea will be very appreciate.

Thanks in advance
Motabrasil

 

[motabrasil]

Dear all

After some arrangements, I'm using the code described below which is working fine.
The only issue I found is: the first gmail is released with its own attachment (one).
However the gmail keep accumulating the attachments from the second on.
I mean, at the end, the fourteenth gmail has 14 attachments.

Any help will be very appreciated

Thanks in advance
motabrasil

***my code...

Sub ReleaseGoogleMail()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim NewFile As String
Dim Flds As Variant
Dim nRow As Long, r As Long
Dim DirFile As Variant, sFile As Variant

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

MailForm.Show

iConf.Load -1
Set Flds = iConf.Fields
With Flds
.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/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/sendusername") = Trim(MailForm.txtGoogleAccount.Text) & "@company.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = MailForm.txtGooglePassword.Text
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With

On Error Resume Next

Sheet2.Activate

nRow = Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To nRow
sFile = Cells(r, 1).Value
DirFile = ActiveWorkbook.Path & "\" & sFile & ".xlsx"
If Len(Dir(DirFile)) = 0 Then
MsgBox "File " & sFile & ".xlsx" & " not found." & Chr(10) & "Please provide it or delete Vendor line"
Exit Sub
Else
With iMsg
Set .Configuration = iConf
.To = Cells(r, "B")
.CC = Cells(r, "C")
.From = Sheet3.Cells(1, "B")
.Subject = Sheet3.Cells(3, "B")
.AddAttachment DirFile
.TextBody = Sheet5.Cells(1, "A") & Chr(10) & _
Sheet5.Cells(2, "A") & Chr(10) & _
Sheet5.Cells(3, "A") & Chr(10) & _
Sheet5.Cells(4, "A") & Chr(10) & _
Sheet5.Cells(5, "A") & Chr(10) & _
Sheet5.Cells(6, "A") & Chr(10) & _
Sheet5.Cells(7, "A") & Chr(10) & _
Sheet5.Cells(8, "A") & Chr(10) & _
Sheet5.Cells(9, "A") & Chr(10) & _
Sheet5.Cells(10, "A") & Chr(10) & _
Sheet5.Cells(11, "A")
.Send
End With
End If
Next r

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub