Excel/Outlook vba - macro to attach multiple files to an Outlook email...

[EverClear]

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:

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

 

[sharma14feb]

my file is not attaching from the location can you please make the changes in the complete code and send me. my requirement is "in coloum A file name, mail id in Coloum B, and the file location is in coloum C" I need a micro which help me to send the mails to the all specified mail id with specified attachment.

 

[Andrew Poulsom]

Which part of the code isn't working now?

 

[sharma14feb]

file attaching