Hello!!! (Using Excel 2010 & Outlook 2010) I am trying to write a macro from Outlook 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:
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 '/// Set workbook/worksheet here 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 '/// Variables set wrong or file name/path have changed 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 '/// Speed up Excel app here ExcelObject.DisplayAlerts = True ExcelObject.EnableEvents = True ExcelObject.ScreenUpdating = True ' Read in the data and create a new message with attachment for each Excel entry 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: '/// Close Excel if we created it, otherwise restore settings 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
This question generated 17 answers. To proceed to the answers, click here.
This thread is current as of March 26, 2013.