CODEWITHSUNDEEP
excelvbaoutlook
Amu
Amu

Reputation: 41

Email a single attachment from folder of files each to a different person

I have a folder with 50 files and I have a list of 50 email addresses. Each file goes to a different email address. Is there a way to write a macro that performs this task?

The problem with the set of code below is two-fold: 1) I have 3 COLUMNS of data in an Excel file: One for subject, one for email address to send to, and the third for the FILE PATH of where the attachment to be attached is stored.

The code below does not allow for a pre-determined set of subject arguments. It also uses ROWS?? for the filepath field instead of a column like it does for send to? So confusing.

Sub Send_Files()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        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
                .to = cell.Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, -1).Value

                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
End Sub

Upvotes: 3

Views: 5896

Answers (1)

0m3r
0m3r

Reputation: 12499

Here is quick example, assuming col A = Email, Col B = Subject & Col C = Path

enter image description here

Option Explicit
Public Sub Example()
   Dim olApp As Object
   Dim olMail As Object
   Dim olRecip As Object
   Dim olAtmt As Object
   Dim iRow As Long
   Dim Recip As String
   Dim Subject As String
   Dim Atmt As String

   iRow = 2

   Set olApp = CreateObject("Outlook.Application")

   Dim Sht As Worksheet
   Set Sht = ThisWorkbook.Worksheets("Sheet1")

   Do Until IsEmpty(Sht.Cells(iRow, 1))

      Recip = Sht.Cells(iRow, 1).Value
      Subject = Sht.Cells(iRow, 2).Value
      Atmt = Sht.Cells(iRow, 3).Value ' Attachment Path

      Set olMail = olApp.CreateItem(0)

      With olMail
         Set olRecip = .Recipients.Add(Recip)
        .Subject = Subject
        .Body = "Hi "
        .Display
         Set olAtmt = .Attachments.Add(Atmt)
         olRecip.Resolve
      End With

      iRow = iRow + 1

   Loop

   Set olApp = Nothing
End Sub

Upvotes: 3

Related Questions