VBA: send email (with attachment) via IBM notes?

Question

I have a workbook like so:

Column B                           Column Q
C:\Folder\file1.xls                [email protected]
C:\Folder\file2.xls                [email protected]
C:\Folder\file3.xls                [email protected]

I want to send an email to each of my recipients in column Q. I do not want to send one email to multiple recipients, instead i want to send 1 email per recipient in the list.

The email subject, body etc will be the same each time, but i also want to attach each of the corresponding workbook from column B for each email.

So for instance, the email sent to recipient 1 will contain the file file1.xls and the email sent to recipient 2 will contain the file file2.xls and so on.

Here is my code:

Sub Macro1()
    ActiveWorkbook.Save

    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim fromAdr As String
    Dim subject As String
    Dim recip As String
    Dim numSend As Integer
    Dim Attachment1 As String

    ' Mail settings
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields

    ' Mail fields
    fromAdr = """[email protected]"
    recip = Range("Q1").Value
    Debug.Print strbody
    subject = "Orders fondsen"
    strbody = strbody & "Hi," & vbNewLine & vbNewLine & _
              "Please find the document..."

    ' Fields layout
    strbody = strbody & vbNewLine & vbNewLine & "Text"
    Debug.Print strbody
    strbody = strbody & vbNewLine & vbNewLine & "Kind regards,"

    ' Location attachment
    Attachment1 = "file-path"

    ' send mail
    On Error GoTo handleError
    With iMsg
   Set .Configuration = iConf
   .To = recip
   .CC = ""
   .From = fromAdr
   .subject = subject
   .TextBody = strbody
   .AddAttachment Attachment1
   .Send
End With
    numSend = numSend + 1
    GoTo skipError

handleError:
    numErr = numErr + 1
    oFile.WriteLine "*** ERROR *** Email for account" & " not sent. Error: " & Err.Number & " " & Err.Description
skipError:

    On Error GoTo 0

    MsgBox "Total number of emails send: " & numSend & vbNewLine & "Total number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished"
    GoTo endProgram
cancelProgram:
    MsgBox "No emails have been sent.", vbOKOnly + vbExclamation, "Operation cancelled"

endProgram:
    Application.Interactive = True
    Set iMsg = Nothing
    Set iConf = Nothing
    Set dp = Nothing
End Sub

At the moment this code will send one email with one attachment. I'm brand new to vba so am not sure how to do this, but please can someone show me to get my code to do what i want?

P.S. i am also getting an error on this line and am not sure why:

 oFile.WriteLine "*** ERROR *** Email for account" & " not sent. Error: " & Err.Number & " " & Err.Description

Thanks in advance

Ben Smith Ben Smith · Accepted Answer · 2017-01-15T20:21:28

You will need to add a loop so that your code can select each of the recipients and add an attachment for each one.

Sub Macro1()
    ActiveWorkbook.Save

    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim fromAdr As String
    Dim subject As String
    Dim recip As String
    Dim numSend As Integer
    Dim Attachment1 As String

    ' Mail settings
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields

    ' Add the loop
    Range("Q1").Select
    While ActiveCell.Value <> ""

    ' Mail fields
    recip = ActiveCell.Value
    Debug.Print strbody
    strbody = strbody & "Hi," & vbNewLine & vbNewLine & _
              "Please find the document..."

    ' Fields layout
    strbody = strbody & vbNewLine & vbNewLine & "Text"
    Debug.Print strbody
    strbody = strbody & vbNewLine & vbNewLine & "Kind regards,"

    ' Location attachment
    Attachment1 = Range("B" & ActiveCell.Row).Value

    ' send mail
    On Error GoTo handleError
    With iMsg
   Set .Configuration = iConf
   .To = recip
   .CC = ""
   .From = "[email protected]"
   .subject = "Orders fondsen"
   .Body = strbody
   .AddAttachment Attachment1
   .Send
End With

    ActiveCell.Offset(1,0).Select
    Wend

    numSend = numSend + 1
    GoTo skipError

handleError:
    numErr = numErr + 1
    oFile.WriteLine "*** ERROR *** Email for account" & " not sent. Error: " & Err.Number & " " & Err.Description
skipError:

    On Error GoTo 0

    MsgBox "Total number of emails send: " & numSend & vbNewLine & "Total number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished"
    GoTo endProgram
cancelProgram:
    MsgBox "No emails have been sent.", vbOKOnly + vbExclamation, "Operation cancelled"

endProgram:
    Application.Interactive = True
    Set iMsg = Nothing
    Set iConf = Nothing
    Set dp = Nothing
End Sub

This code, or something very similar, should work.

VBA: send email (with attachment) via IBM notes?

1 Answers