Consulting

Results 1 to 11 of 11

Thread: Macro to send email with multiple attachment

  1. #1

    Macro to send email with multiple attachment

    hi every one,

    I have the below macro which goes onto outlook and works very well, however, it has one limitation that i can send only one file as an attachment. I was wondering if it is possible to add multiple attachments instead of just one attachment per email. every thing else in the code is fine, just to add additional code to add multiple attachments. for example, in the below macro, outlook picks up information from cell a, cell b and cell c in an excel file containing file name, email address of recipient and file path. Now is it possible that multiple file names can be put in cell A to attach to a single email? or any other way to do this. Because I have list of clients to whom i send multiple files to each of them. The below macro only allows me to send one file in one email and i have to send each client multiple emails for each attachment.

    please help me in this as this will really solve my problem if the below code can be modified to include multiple attachments.

    thanks and best regards,
    CJ

    [VBA]

    Sub ReadExcel()
    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

    ' 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 fName
    With NewMessage
    .Recipients.Add eAddress
    .Attachments = fName
    .Display
    ' .Subject = "Put your subject here"
    ' .Send
    End With
    CellRow = CellRow + 1
    fNameAddress = "A" & CellRow
    Loop
    End Sub

    [/VBA]

  2. #2
    VBAX Expert JP2112's Avatar
    Joined
    Oct 2008
    Location
    Astoria, NY
    Posts
    590
    Location
    Welcome to VBAX. Please use [vba][/vba] tags when posting code.

    Can you add the additional attachment filenames to columns on the right? Then you could simply call ".Attachments.Add" on each cell's value.
    Regards,
    JP

    Read the FAQ
    Getting free help on the web
    My website
    Please use [vba][/vba] tags when posting code

  3. #3
    Site Admin
    Urban Myth
    VBAX Guru
    Joined
    May 2004
    Location
    Oregon, United States
    Posts
    4,940
    Location
    A few suggestions regarding your code.

    • You set Outlook application objects multiple times with each iteration, you only need it once
    • Your variables, i.e. fName, fLoc, etc, are being declared as Variant type - only the last item on that line is actually being delcared as a String
    • If Excel is not open, why not open it?
    • How do you know what file to use?
    • If coding from Outlook, there's no need to declare a variable as "Outlook.Type", as it's assumed since that's the Object Model you're running from
    • You don't actually show what "fNameAddress" should be to start


    While I don't know the answer to the above questions, here is a generic rendition of your code...

    [VBA]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

    '/// New variables not previously declared
    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 = "Book1.xls"
    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)
    NewMessage.Attachments.Add oWS.Range("C" & iLoop).Value & "\" & Trim(aAttach(iStep))
    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
    [/VBA]

    Not sure if this will work for you, let us know.

  4. #4

    just a small amendment to the code

    Hi Zack,

    firstly, thank you so much for this amazing code, i tried it and it works really well. thanks alot really.

    i am having only one issue with the code now after trying it for two days. when i run the code, it looks for file name defined in column a in locaion defined in location c. now if the file does not exist in the specified location, the code stops with error and does not complete the process for the rest of the rows.

    what I am looking for is to amend the code so that in case out of all the file names mentioned in column a , if it does not find the file specified in column a, it just skips that file and move on to search and pick teh next file and complete the process till the end for all the rows. it may give a message only that the file does not exist but the code continues till the end.

    Pleaseeee look into this and see if it is possible to amend the code a bit.

    thanks again for all the help and for your effort on this.

    Best regards,
    CJ

  5. #5
    Site Admin
    Urban Myth
    VBAX Guru
    Joined
    May 2004
    Location
    Oregon, United States
    Posts
    4,940
    Location
    No problem. Just change this line of code...

    [vba]NewMessage.Attachments.Add oWS.Range("C" & iLoop).Value & "\" & Trim(aAttach(iStep)) [/vba]

    ... to these lines of code...

    [vba]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[/vba]

  6. #6
    Zack Barresse, you are awesome. I dont even have a project that i could use that code with, but im going to come up with one, just so i can.

  7. #7

    thanks a lot, another catch...

    Dear Zack,

    thank you so much for modifying the code. Now the last issue i am facing is that when I run the macro with the Newmessage.send in outlook, it gives an error that "outlook does not recognize one or more names." and the process stops at the very start without moving to teh next email.

    Is there any way to make outlook send the email without checking the address book of the validity of the email address? What i think is causing this is because the macro tries to send the email immediately while outlook takes a couple to seconds to recognize the email address, can you please solve this issue?

    i have attached the screenshot of the error that i am getting. please check the possibility as I still have to send the email manually. Outlook still attaches the files but i disable the newmessage.send option and then manually click send to all the emails attachments generated by the macro. by the time i go to each email, outlook has already recognized the email addresses.

    Thanks a lot Zack for your help on this, please check if what i am asking can be done.

    best regards,
    CJ
    Attached Files Attached Files

  8. #8
    Site Admin
    Urban Myth
    VBAX Guru
    Joined
    May 2004
    Location
    Oregon, United States
    Posts
    4,940
    Location
    Ah, you have to separate recipients with a semi-colon. This line should have this slight amendment...

    [vba] NewMessage.Recipients.Add oWS.Range("B" & iLoop).Value & ";"[/vba]

    You can send automatically, but not natively through Outlook in lieu of security. You can do so with other options, i.e. ClickYes (what I use), Outlook Redemption, etc.

  9. #9
    VBAX Newbie
    Joined
    Jun 2013
    Posts
    2
    Location
    Hi Zack,

    Your code is really great but I encountered this error:
    "Set NewMessage = OutlookApp.CreateItem(olMailItem)"
    (Run-time error '438':

    Object doesn;t support this property or method.

    I have no idea what the problem might be. I'm only the beginner. I would appreciate your help.

  10. #10
    Site Admin
    Urban Myth
    VBAX Guru
    Joined
    May 2004
    Location
    Oregon, United States
    Posts
    4,940
    Location
    Krisu83: Feel free to make your own post and include a URL to this post, rather than hijacking it. And feel free to send me a private message with your new posts URL so I can look at it. For your new post, if you can post all of your code, or better yet a small sample workbook where you're receiving this error, would be most helpful.

  11. #11
    VBAX Newbie
    Joined
    Jun 2013
    Posts
    2
    Location
    Apologies Thanks for your reply.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •