Sending email with multiple attachments
 

I found information to send an email with attachments using an excel spreadsheet. It is working perfectly. I now need to update it so that I can add multiple attachments. The documents reside in columns c:m. Any ideas?

Sub Test()
Dim ExcelObject As Object
Dim OutlookApp As Outlook.Application
Dim NewMessage As Outlook.MailItem
Dim OutlookNamespace As Outlook.NameSpace
Dim fName, fLoc, eAddress As String
Dim fNameAddress, fLocAddress, eAddressAddress As String
Dim strHTMLBody As String


' Set up the spreadsheet you want to read
On Error Resume Next
Set ExcelObject = GetObject(, "Excel.Application")
If Not Err.Number = 0 Then
MsgBox "You need to have Excel running with the appropriate spreadsheet open first", vbCritical, "Excel Not Running"
End
End If

' Read in the data and create a new message with attachment for each Excel entry
CellRow = 1
Set OutlookApp = Outlook.Application
Do Until ExcelObject.Range(fNameAddress) = ""
fNameAddress = "A" & CellRow
eAddressAddress = "B" & CellRow
fLocAddress = "C" & CellRow
fName = ExcelObject.Range(fNameAddress)
fLoc = ExcelObject.Range(fLocAddress)
eAddress = ExcelObject.Range(eAddressAddress)
fName = fLoc & "\" & fName
Set OutlookApp = Outlook.Application
Set NewMessage = OutlookApp.CreateItem(olMailItem)
Set myAttachments = NewMessage.Attachments
myAttachments.Add fLoc
With NewMessage
.Recipients.Add eAddress
.Attachments = fLoc
.Display
.Subject = "Action Required: FY13 Budget Development Form"
.HTMLBody = strHTMLBody
strHTMLBody = "<br<FONT FACE=TAHOMA Attached find your school's budget form.
' .Send
End With
CellRow = CellRow + 1
fNameAddress = "A" & CellRow
Loop
End Sub