Hello!!!</SPAN>
(Using Excel 2010 & Outlook 2010)</SPAN>
I am trying to write a macro from </SPAN>Outlook</SPAN> to send an email with multiple Excel files attached to a recipient. What the macro will do is read in a separate Excel file containing a list of the filenames in Column A, the email addresses of the recipients in Column B, and the file pathway in Column C.
The macro sort of works. That is to say, it doesn't crash. The problem is that if there are *multiple* files to attach in the email, the macro will create multiple emails. So if I have 9 files to attach, the macro will create 9 emails to the same recipient.
How can I adjust my code to attach multiple files to *single* email? Here's what I have so far:
(Using Excel 2010 & Outlook 2010)</SPAN>
I am trying to write a macro from </SPAN>Outlook</SPAN> to send an email with multiple Excel files attached to a recipient. What the macro will do is read in a separate Excel file containing a list of the filenames in Column A, the email addresses of the recipients in Column B, and the file pathway in Column C.
The macro sort of works. That is to say, it doesn't crash. The problem is that if there are *multiple* files to attach in the email, the macro will create multiple emails. So if I have 9 files to attach, the macro will create 9 emails to the same recipient.
How can I adjust my code to attach multiple files to *single* email? Here's what I have so far:
Rich (BB code):
Option Explicit
Sub ReadExcel()
Dim ExcelObject As Object
Dim OutlookApp As Application
Dim NewMessage As MailItem
Dim NS As NameSpace
Dim fName As String
Dim fLoc As String
Dim eAddress As String
Dim fNameAddress As String
Dim fLocAddress As String
Dim eAddressAddress As String
Dim myAttachments As Attachments
Dim oWB As Object
Dim oWS As Object
Dim bExcelCreated As Boolean
Dim bBookOpened As Boolean
Dim CellRow As Long
Dim iLastRow As Long
Dim iLoop As Long
Dim iStep As Long
Dim aAttach() As String
Const sWBName As String = "mailfile.xlsm"
Const sWBPath As String = "C: \PathGoesHere"
Const sWSName As String = "Sheet1"
Const sDelim As String = ";"
' Set up the spreadsheet you want to read
On Error Resume Next
Set ExcelObject = GetObject(, "Excel.Application")
bExcelCreated = False
If ExcelObject Is Nothing Then
Set ExcelObject = CreateObject("Excel.Application")
bExcelCreated = True
End If
</SPAN>'/// Set workbook/worksheet here</SPAN>
If WORKBOOKISOPEN(sWBName, ExcelObject) = True Then
Set oWB = ExcelObject.Workbooks(sWBName)
bBookOpened = False
Else
Set oWB = ExcelObject.Workbooks.Open(sWBPath & sWBName)
bBookOpened = True
End If
If oWB Is Nothing Then
</SPAN>'/// Variables set wrong or file name/path have changed</SPAN>
MsgBox "There was an error opening the file '" & sWBName & "'."
GoTo ExitEarly
End If
Set oWS = oWB.Worksheets(sWSName)
If oWS Is Nothing Then
MsgBox "There was an error getting the sheet name in file '" & sWBName & "'."
GoTo ExitEarly
End If
On Error GoTo 0
</SPAN> '/// Speed up Excel app here</SPAN>
ExcelObject.DisplayAlerts = True
ExcelObject.EnableEvents = True
ExcelObject.ScreenUpdating = True
' </SPAN>Read in the data and create a new message with attachment for each Excel entry</SPAN>
CellRow = 1
iLastRow = oWS.Cells(oWS.Rows.Count, 1).End(-4162).Row
Set OutlookApp = Application
For iLoop = CellRow To iLastRow
aAttach() = Split(oWS.Range("A" & iLoop).Value, sDelim)
Set NewMessage = OutlookApp.CreateItem(olMailItem)
NewMessage.Recipients.Add oWS.Range("B" & iLoop).Value & ";"
For iStep = LBound(aAttach) To UBound(aAttach)
If Dir(oWS.Range("C" & iLoop).Value & "\" & Trim(aAttach(iStep)), vbNormal) <> "" Then
NewMessage.Attachments.Add oWS.Range("C" & iLoop).Value & "\" & Trim(aAttach(iStep))
End If
Next iStep
NewMessage.Subject = ""
NewMessage.Body = ""
NewMessage.Display
Next iLoop
ExitEarly:
</SPAN> '/// Close Excel if we created it, otherwise restore settings</SPAN>
If bBookOpened = True Then
oWB.Close False
End If
If bExcelCreated = True Then
ExcelObject.Quit
Else
ExcelObject.DisplayAlerts = True
ExcelObject.EnableEvents = True
ExcelObject.ScreenUpdating = True
End If
End Sub
Function WORKBOOKISOPEN(wkbName As String, oApp As Object) As Boolean
On Error Resume Next
WORKBOOKISOPEN = CBool(oApp.Workbooks(wkbName).Name <> "")
On Error GoTo 0
End Function
Last edited by a moderator:
