Attatch multiple files form a folder to a e-mail(gmail) using VBA

[danilogon]

Hi,

I have a code to automatically send e-mails via gmail, but I need to attach a couple of files that are in a specific folder.I tryed code it, but didn´t work.

I can´t make a code with a specific name for the files, because every moth when we send the e-mails, they are with different names. The only thing that never changes is the location that the files are in the computor, as they are specified in the sheet (example bellow)

Can anyone help me??

Seller	e-mail1	email2	email3	email4	Body	Folder	Status
Thiago Goncalves	danilogon@gmail.com				Segue em anexo o relatorio de vendas	C:\Users\Admin\Desktop\RELATORIOS\Thiago
Danilo Goncalves	danilogon2@gmail.com				Segue em anexo o relatorio de vendas	C:\Users\Admin\Desktop\RELATORIOS\Danilo

Sub Send_Emails()

For Line = 2 To 200

Dim NewMail As CDO.Message
Dim mailConfig As CDO.Configuration
Dim fields As Variant
Dim msConfigURL As String
On Error GoTo Err:

'early binding
Set NewMail = New CDO.Message
Set mailConfig = New CDO.Configuration

'load all default configurations
mailConfig.Load -1

Set fields = mailConfig.fields

'Set All Email Properties
With NewMail
.From = ""
.To = Cells(Line, 2).Value & "," & Cells(Line, 3).Value & "," & Cells(Line, 4).Value & "," & Cells(Line, 5).Value
.CC = ""
.BCC = ""
.Subject = "Faturas do mês"
.TextBody = "Segue em anexo planilha do mês"

End With

msConfigURL = "http://schemas.microsoft.com/cdo/configuration"

With fields
.Item(msConfigURL & "/smtpusessl") = True 'Enable SSL Authentication
.Item(msConfigURL & "/smtpauthenticate") = 1 'SMTP authentication Enabled
.Item(msConfigURL & "/smtpserver") = "smtp.gmail.com" 'Set the SMTP server details
.Item(msConfigURL & "/smtpserverport") = 465 'Set the SMTP port Details
.Item(msConfigURL & "/sendusing") = 2 'Send using default setting
.Item(msConfigURL & "/sendusername") = "" 'Your gmail address
.Item(msConfigURL & "/sendpassword") = "" 'Your password or App Password
.Update 'Update the configuration fields
End With
NewMail.Configuration = mailConfig
NewMail.Send

Cells(Line, 8) = "Enviado"

Next

Exit_Err:
'Release object memory
Set NewMail = Nothing
Set mailConfig = Nothing
End

Err:
Select Case Err.Number
Case -2147220973 'Could be because of Internet Connection
MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " & Err.Description
Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " & Err.Description
Case Else 'Report other errors
MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " & Err.Description
End Select

Resume Exit_Err

End Sub

 

[Jeffrey Mahoney]

The code below allows me to attach multiple files to one email. in the example cell below, I have each file name separated by semi colons. The code reads that and parses them

Early Phase CS Meeting - Detail Sheets - 2023_01.xlsx ;Meeting Action Tracker - Early Phase - 2023_01 - Pre-Read.xlsx ;Option Selection Report - 2023_01.xlsx

Public EmailTo As String
Public EmailFrom As String
Public EmailCC As String
Public EmailSubject As String
Public EmailBody As String
Public EmailPath As String
Public EmailFileName As String



Sub CreateEmail()

  Dim objOutlook As Object
  Dim objMail As Object
  Dim A As String
  Dim Q As String
  Dim OutAccnt As Outlook.account
  Dim xOutMsg As String
  Dim Hrt As String
  Dim EmailFile(10) As String
  Dim EmailFileCnt As Long
  Dim X As Long
  Dim Y As Long
  Dim s1 As Long
  Dim s2 As Long
  Dim EmailPathFile As String
  Dim PathFileError As String
  
  
  Set objOutlook = CreateObject("Outlook.Application")
  Set objMail = objOutlook.CreateItem(0)
  If EmailFrom <> "" Then
    Set OutAccnt = objOutlook.Session.Accounts.Item(EmailFrom)
  End If
  

  xOutMsg = "<font style=font-size:14pt;font-family:Calibri;color:#000000>"
  xOutMsg = xOutMsg & EmailBody & vbNewLine & "</font>"
  
  If EmailPath <> "" And Right(EmailPath, 1) <> "\" Then EmailPath = EmailPath & "\"
  
  If EmailFileName <> "" Then
    EmailFileCnt = Len(EmailFileName) - Len(Replace(EmailFileName, ";", "")) + 1
    If EmailFileCnt = 1 Then
      EmailFile(1) = EmailFileName
    Else
      For X = 1 To EmailFileCnt
        s2 = InStr(s1 + 1, EmailFileName, ";")
        If X = 1 Then
          EmailFile(1) = Trim(Left(EmailFileName, s2 - 1))
          s1 = s2
        ElseIf X = EmailFileCnt Then
          EmailFile(X) = Mid(EmailFileName, s1 + 1, 100)
        ElseIf X > 1 And X < EmailFileCnt Then
          EmailFile(X) = Trim(Mid(EmailFileName, s1 + 1, s2 - s1 - 1))
          s1 = s2
        End If
      Next X
    End If
  End If
    
               
  With objMail
    
    .BodyFormat = olFormatHTML
    .SendUsingAccount = OutAccnt              'Supposedly allows the correct Signature to be loaded
    If EmailFrom <> "" Then
      .SentOnBehalfOfName = OutAccnt            'Group email account
    End If
    .To = EmailTo
    .CC = EmailCC
    '.bcc = "Bla"
    .Subject = EmailSubject
    .Display                   'Instead of .Display, you can use .Send to send the email
    .HTMLBody = xOutMsg & .HTMLBody               'Put this after .Display to save the signature
    On Error GoTo WeThePeople
    For X = 1 To EmailFileCnt
      EmailPathFile = EmailPath & EmailFile(X)
      PathFileError = EmailPathFile
      .Attachments.Add EmailPathFile, 1
    Next X

    '.Send                                 or .Save to save a copy in the drafts folder
  End With





  Set objOutlook = Nothing
  Set objMail = Nothing
  Exit Sub
  
WeThePeople:
  MsgBox "There was a problem attaching this file: " & vbNewLine & PathFileError


End Sub

 

[CalvinGamble]

The code below allows me to attach multiple files to one email. in the example cell below, I have each file name separated by semi colons. The code reads that and parses them

Early Phase CS Meeting - Detail Sheets - 2023_01.xlsx ;Meeting Action Tracker - Early Phase - 2023_01 - Pre-Read.xlsx ;Option Selection Report - 2023_01.xlsx

Public EmailTo As String
Public EmailFrom As String
Public EmailCC As String
Public EmailSubject As String
Public EmailBody As String
Public EmailPath As String
Public EmailFileName As String



Sub CreateEmail()

  Dim objOutlook As Object
  Dim objMail As Object
  Dim A As String
  Dim Q As String
  Dim OutAccnt As Outlook.account
  Dim xOutMsg As String
  Dim Hrt As String
  Dim EmailFile(10) As String
  Dim EmailFileCnt As Long
  Dim X As Long
  Dim Y As Long
  Dim s1 As Long
  Dim s2 As Long
  Dim EmailPathFile As String
  Dim PathFileError As String
 
 
  Set objOutlook = CreateObject("Outlook.Application")
  Set objMail = objOutlook.CreateItem(0)
  If EmailFrom <> "" Then
    Set OutAccnt = objOutlook.Session.Accounts.Item(EmailFrom)
  End If
 

  xOutMsg = "<font style=font-size:14pt;font-family:Calibri;color:#000000>"
  xOutMsg = xOutMsg & EmailBody & vbNewLine & "</font>"
 
  If EmailPath <> "" And Right(EmailPath, 1) <> "\" Then EmailPath = EmailPath & "\"
 
  If EmailFileName <> "" Then
    EmailFileCnt = Len(EmailFileName) - Len(Replace(EmailFileName, ";", "")) + 1
    If EmailFileCnt = 1 Then
      EmailFile(1) = EmailFileName
    Else
      For X = 1 To EmailFileCnt
        s2 = InStr(s1 + 1, EmailFileName, ";")
        If X = 1 Then
          EmailFile(1) = Trim(Left(EmailFileName, s2 - 1))
          s1 = s2
        ElseIf X = EmailFileCnt Then
          EmailFile(X) = Mid(EmailFileName, s1 + 1, 100)
        ElseIf X > 1 And X < EmailFileCnt Then
          EmailFile(X) = Trim(Mid(EmailFileName, s1 + 1, s2 - s1 - 1))
          s1 = s2
        End If
      Next X
    End If
  End If
   
              
  With objMail
   
    .BodyFormat = olFormatHTML
    .SendUsingAccount = OutAccnt              'Supposedly allows the correct Signature to be loaded
    If EmailFrom <> "" Then
      .SentOnBehalfOfName = OutAccnt            'Group email account
    End If
    .To = EmailTo
    .CC = EmailCC
    '.bcc = "Bla"
    .Subject = EmailSubject
    .Display                   'Instead of .Display, you can use .Send to send the email
    .HTMLBody = xOutMsg & .HTMLBody               'Put this after .Display to save the signature
    On Error GoTo WeThePeople
    For X = 1 To EmailFileCnt
      EmailPathFile = EmailPath & EmailFile(X)
      PathFileError = EmailPathFile
      .Attachments.Add EmailPathFile, 1
    Next X

    '.Send                                 or .Save to save a copy in the drafts folder
  End With





  Set objOutlook = Nothing
  Set objMail = Nothing
  Exit Sub
 
WeThePeople:
  MsgBox "There was a problem attaching this file: " & vbNewLine & PathFileError


End Sub

Thank you for this helpful topic and detailed explanation! I was looking for how to create folders in Gmail and found this link: https://setapp.com/how-to/how-to-create-folders-in-gmail / And later on found your helpful forum! Thanks for sharing this info! Now I will know how to attatch multiple files form a folder.

Thank you sir for saving my day. I appreciate you.
And I am sorry for the bump, I always appreciate the person who helps me.