E-mail all files from one folder

[seancrim]

Hello all,

I am trying to create VBA code that will take the code below were column C is the e-mail and other data is taken from the work book but I want to change the file name (column F) to now include all files from one folder instead of one specific file. I can specify the folder in column F, but I need the VBA code to gather the files and attach them to an email. The file names will change in each folder I specify.

Can anyone offer any suggestions?


Code:

Sub CreateMailMerge()

Dim OutApp As Object
Dim OutMail As Object
Dim FileName1 As String
Dim FileName2 As String
Dim FileName3 As String
Dim FileName4 As String
Dim FileName5 As String
Dim ErrorString As String
Dim ErrorCount As Integer

'Set Outlook as default program

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
' MailOpen = 0

'Initialise File

Sheets("Contacts List").Activate
Sheets("Contacts List").Columns("A:A").ClearContents
Sheets("Contacts List").Columns("A:A").Interior.Pattern = xlNone
Sheets("Contacts List").Range("A2") = "File Check"
'Check for files existing

Sheets("Contacts List").Range("C3").Select
ErrorCount = 0
While Not (ActiveCell = "")
ErrorString = ""
'Check first file, column F

If Sheets("Contacts List").Range("F" & ActiveCell.Row) = "" Then
FileName1 = ""
Else
FileName1 = Sheets("Contacts List").Range("F1") & "" & Sheets("Contacts List").Range("F" & ActiveCell.Row)
If Not Sheets("Contacts List").Range("F" & ActiveCell.Row) = Dir$(FileName1) Then
ErrorString = ErrorString & "File " & FileName1 & " in cell F" & ActiveCell.Row & " not found. "
ErrorCount = ErrorCount + 1
End If
End If

'Check second file, column G

If Sheets("Contacts List").Range("G" & ActiveCell.Row) = "" Then
FileName2 = ""
Else
FileName2 = Sheets("Contacts List").Range("G1") & "" & Sheets("Contacts List").Range("G" & ActiveCell.Row)
If Not Sheets("Contacts List").Range("G" & ActiveCell.Row) = Dir$(FileName2) Then
ErrorString = ErrorString & "File " & FileName2 & " in cell G" & ActiveCell.Row & " not found. "
ErrorCount = ErrorCount + 1
End If
End If

'Check third file, column H

If Sheets("Contacts List").Range("H" & ActiveCell.Row) = "" Then
FileName3 = ""
Else
FileName3 = Sheets("Contacts List").Range("H1") & "" & Sheets("Contacts List").Range("H" & ActiveCell.Row)
If Not Sheets("Contacts List").Range("H" & ActiveCell.Row) = Dir$(FileName3) Then
ErrorString = ErrorString & "File " & FileName3 & " in cell H" & ActiveCell.Row & " not found. "
ErrorCount = ErrorCount + 1
End If
End If

'Check fourth file, column I

If Sheets("Contacts List").Range("I" & ActiveCell.Row) = "" Then
FileName4 = ""
Else
FileName4 = Sheets("Contacts List").Range("I1") & "" & Sheets("Contacts List").Range("I" & ActiveCell.Row)
If Not Sheets("Contacts List").Range("I" & ActiveCell.Row) = Dir$(FileName4) Then
ErrorString = ErrorString & "File " & FileName4 & " in cell I" & ActiveCell.Row & " not found. "
ErrorCount = ErrorCount + 1
End If
End If

'Check fifth file, column J

If Sheets("Contacts List").Range("J" & ActiveCell.Row) = "" Then
FileName5 = ""
Else
FileName5 = Sheets("Contacts List").Range("J1") & "" & Sheets("Contacts List").Range("J" & ActiveCell.Row)
If Not Sheets("Contacts List").Range("J" & ActiveCell.Row) = Dir$(FileName5) Then
ErrorString = ErrorString & "File " & FileName5 & " in cell J" & ActiveCell.Row & " not found. "
ErrorCount = ErrorCount + 1
End If
End If

If ErrorString = "" Then
Sheets("Contacts List").Range("A" & ActiveCell.Row) = "Ready to Send"
Else
Sheets("Contacts List").Range("A" & ActiveCell.Row) = ErrorString
Sheets("Contacts List").Range("A" & ActiveCell.Row).Interior.Color = 255
End If

Sheets("Contacts List").Range("C" & ActiveCell.Row + 1).Select

Wend

If Not ErrorCount = 0 Then
Sheets("Contacts List").Range("A1") = ErrorCount & " errors detected, no e-mails have been sent."
Sheets("Contacts List").Range("A1").Interior.Color = 255
Else

'Begin Mail Merge

Sheets("Contacts List").Range("C3").Select

While Not (ActiveCell = "")

Set OutMail = OutApp.CreateItem(0)

With OutMail
If Not Sheets("Setup").Range("A13") = "" Then
.SentOnBehalfOfName = Sheets("Setup").Range("A13")
End If
.To = Range("C" & ActiveCell.Row)
.Subject = Sheets("Setup").Range("A4") & " - " & Sheets("Contacts List").Range("B" & ActiveCell.Row)
.HTMLbody = Sheets("Setup").Range("A7") & " " & Sheets("Contacts List").Range("E" & ActiveCell.Row) & ",<br>" & Sheets("Setup").Range("A10")
If Not Sheets("Contacts List").Range("F" & ActiveCell.Row) = "" Then
.Attachments.Add Sheets("Contacts List").Range("F1") & "" & Sheets("Contacts List").Range("F" & ActiveCell.Row)
End If
If Not Sheets("Contacts List").Range("G" & ActiveCell.Row) = "" Then
.Attachments.Add Sheets("Contacts List").Range("G1") & "" & Sheets("Contacts List").Range("G" & ActiveCell.Row)
End If
If Not Sheets("Contacts List").Range("H" & ActiveCell.Row) = "" Then
.Attachments.Add Sheets("Contacts List").Range("H1") & "" & Sheets("Contacts List").Range("H" & ActiveCell.Row)
End If
If Not Sheets("Contacts List").Range("I" & ActiveCell.Row) = "" Then
.Attachments.Add Sheets("Contacts List").Range("I1") & "" & Sheets("Contacts List").Range("I" & ActiveCell.Row)
End If
If Not Sheets("Contacts List").Range("J" & ActiveCell.Row) = "" Then
.Attachments.Add Sheets("Contacts List").Range("J1") & "" & Sheets("Contacts List").Range("J" & ActiveCell.Row)
End If
.send
Set OutMail = Nothing
End With

Sheets("Contacts List").Range("A" & ActiveCell.Row) = "Sent"
Sheets("Contacts List").Range("C" & ActiveCell.Row + 1).Select

Wend

End If
Range("A1").Select

End Sub