Consulting

Results 1 to 2 of 2

Thread: Email multiple people with different attachments (2 attachments per email)

  1. #1
    VBAX Regular
    Joined
    Jul 2017
    Posts
    24
    Location

    Email multiple people with different attachments (2 attachments per email)

    I have a list of 13 emails which I would need to send individual emails to as they require 2 different attachments for them.

    Here is what I have to send one attachment and works fine:
    Column A - Greetings, (Good Morning or Good Afternoon, depends on the time I send out)
    Column B - Recipient's email address
    Column C - Attachment (file path)
    Column D - Attachment name (file name)
    Column E - Email Subject

    Note: the attachments need send to example3 are the only excel file, the rest are all pdfs.

    ref# Email File Path File Name Recipient's Subject
    Good Afternoon example1@gmail.com C:\Users\Desktop\Example1.pdf Example1_2018-08.pdf Example1 as of August 2018
    Good Afternoon example2@gmail.com C:\Users\Desktop\Example2.pdf Example2_2018-08.pdf Example2 as of August 2018
    Good Afternoon example3@gmail.com C:\Users\Desktop\Example3.xlsx Example2_2018-08.xlsx Example3 as of August 2018


    Now, what I need the VBA to do is to send Recipient example1 two attachments: the file name end with "2018-08", will change to "2018-09" next time, but the second attachment will stay the same.
    Example1_2018-08.pdf and Example1.pdf
    Example2_2018-08.pdf and Example2.pdf
    Example3_2018-08.xlsx and Example3.xlsx
    ......


    Here is my current code:

    Sub Get_Files()
        Dim SourceDir, R
        Dim fso, Fldr, Files, File
        Dim Sht
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        Sht = "Summary"
        Sheets(Sht).Range("A2:D100000").ClearContents
        SourceDir = "C:\Users\Desktop"
        R = 1
        If (fso.folderexists(SourceDir)) Then
            Set Fldr = fso.getfolder(SourceDir)
            Set Files = Fldr.Files
            For Each File In Files
                If (Right(File.Name, 3) = "pdf") Then
                R = R + 1
                Sheets(Sht).Cells(R, "D").Value = File.Name
                End If
                
                If (Right(File.Name, 4) = "xlsx") Then
                R = R + 1
                Sheets(Sht).Cells(R, "D").Value = File.Name
                End If
            Next
        End If
                
        
        Call DeleteRows
        
        
        
        Worksheets("Summary").Activate
        Range("D1").FormulaR1C1 = "C:\Users\Desktop\"
        Range("A2").FormulaR1C1 = "=IF(MOD(NOW(),1)<0.5,""Good Morning "",IF(MOD(NOW(),1)<0.75,""Good Afternoon "",""Good Evening ""))"
        Range("B2").FormulaR1C1 = "=VLOOKUP(LEFT(RC[2],FIND(""_"",RC[2],FIND(""_"",RC[2])+1)-1),Emails!C[-1]:C,2,FALSE)"
        Range("C2").FormulaR1C1 = "=R1C4&RC[1]"
        Range("F2").FormulaR1C1 = "='Rename Files'!R2C4"
        Range("G2").FormulaR1C1 = "=TEXT(DATE(2000,'Rename Files'!R2C5,1),""mmmm"")"
        Range("A2").AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, "D").End(xlUp).Row)
        Range("C2").AutoFill Destination:=Range("C2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
        Range("B2").AutoFill Destination:=Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row)
        Range("F2").AutoFill Destination:=Range("F2:F" & Cells(Rows.Count, "A").End(xlUp).Row)
        Range("G2").AutoFill Destination:=Range("G2:G" & Cells(Rows.Count, "A").End(xlUp).Row)
    
    
      
        Columns("A:C").Select
        Range("A2").Activate
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        
        Columns("F:G").Select
        Range("F2").Activate
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        
        Range("D1") = "File Name"
        Range("A1").Select
        
        Call RecipientsName
        
        Columns("F:G").Select
        Selection.Delete
        
    
    
        
    End Sub
    
    
    Sub DeleteRows()
        Dim c As Range
        Dim SrchRng
        
        Worksheets("Summary").Activate
        
        Set SrchRng = ActiveSheet.Range("D1", ActiveSheet.Range("D65536").End(xlUp))
        Do
            Set c = SrchRng.Find("Report", LookIn:=xlValues)
            If Not c Is Nothing Then c.EntireRow.Delete
            
        Loop While Not c Is Nothing
        
        Set SrchRng = ActiveSheet.Range("D1", ActiveSheet.Range("D65536").End(xlUp))
        Do
            Set c = SrchRng.Find("Example", LookIn:=xlValues)
            If Not c Is Nothing Then c.EntireRow.Delete
            
        Loop While Not c Is Nothing
        
        
    End Sub
    
    
    Sub RecipientsName()
        
        Range("E2").Select
        ActiveCell.FormulaR1C1 = _
            "=LEFT(RC[-1],FIND(""_"",RC[-1],FIND(""_"",RC[-1])+1)-1)&"" as of ""&RC[2] &"" "" &RC[1]"
       
        Range("E2").Copy
        Range("E2").AutoFill Destination:=Range("E2:E" & Cells(Rows.Count, "D").End(xlUp).Row)
        Range("E2:E65000").Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    
    
        Range("E1") = "Recipient's Subject"
        Range("E1").Font.Bold = True
    
    
    
    
    
    
    End Sub
    
    
    Sub Send_Files()
    'Working in Excel 2000-2016
    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
        Dim OutApp As Object
        Dim OutMail As Object
        Dim sh As Worksheet
        Dim cell As Range
        Dim FileCell As Range
        Dim rng As Range
        Dim answer As Integer
    
    
        answer = MsgBox("Are you sure you want to send files?", vbYesNo + vbQuestion, "Send Files")
        
        If answer = vbYes Then
    
    
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
    
        Set sh = Sheets("Summary")
    
    
        Set OutApp = CreateObject("Outlook.Application")
    
    
        For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    
    
            
            Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
    
    
            If cell.Value Like "?*@?*.?*" And _
               Application.WorksheetFunction.CountA(rng) > 0 Then
                Set OutMail = OutApp.CreateItem(0)
    
    
            With OutMail
            .Display
            End With
            Signature = OutMail.HTMLBody
            
                With OutMail
                    .to = cell.Value
                    .cc = "xxxx@gmail.com"
                    .Subject = cell.Offset(0, 3).Value
                     .HTMLBody = "<font face = Times New Roman><p style=font-size:14.5px>" & cell.Offset(0, -1).Value & "," _
                    & "<br><br> Please find attached your monthly schedule for xxxxxxxx." _
                    & "<br><br> Thank you. " _
                    & "<br><br> Sincerely," & Signature
    
    
                    For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                        If Trim(FileCell) <> "" Then
                            If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                            End If
                        End If
                    Next FileCell
    
    
                    .Send  'Or use .Display
                End With
    
    
                Set OutMail = Nothing
            End If
        Next cell
    
    
        Set OutApp = Nothing
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
        
        Else
            'do nothing
        End If
        
    
    End Sub
    

    Example1_2018-08.pdf

  2. #2
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    Review this example and incorporate into your own project :

    Option Explicit
    Sub SendEmailfromOutlook()
    
    
    
    
        Dim OutApp As Object
        Dim OutMail As Object
        Dim cell As Range
        Dim Path As String
        
        Path = Application.ActiveWorkbook.Path
        Set OutApp = CreateObject("Outlook.Application")
    
    
    
    
        For Each cell In Range("C3:C10")
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = cell.Value
                .Subject = Cells(cell.Row, "D").Value
                .Body = "Dear " & Cells(cell.Row, "B").Value & "," _
                & vbNewLine & vbNewLine & _
                "Please find attached a list of overdue invoices. Thank you!"
              '  .Attachments.Add (Path & "" & Cells(cell.Row, "D").Value)
                If Not Cells(cell.Row, "E").Value = "" Then .Attachments.Add _
                (Path & "" & Cells(cell.Row, "E").Value)
                If Not Cells(cell.Row, "F").Value = "" Then .Attachments.Add _
                (Path & "" & Cells(cell.Row, "F").Value)
    '.Send
                .Display
                .Save
            End With
        Next cell
        
    End Sub
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •