Loop function in VBA to send multiple emails

Question

I have a Excel VBA (Send_Mail) to send emails through Lotus Notes. It is working fine, however I need to send individual email to multiple people in one go.

In my Excel sheet. Cell A7 downwards will be the email addresses that can go up to 200+ rows, B7 has the subject Line and Cell C7 has the body of email. (all of this is getting auto populated with a different macro). However my code (Send_Mail) is just sending one email to the address which is in cell A7. I need to send mail to all the email address that are in Col A7 onwards with its respective subject (Col B) and mail body (col C).

Below is my code:

Public TOID As String
Public CCID As String
Public SECT As String
Public ACCO As String
Public SUBJ As String

Sub Send_Mail()

Dim answer As Integer

answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ??  Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES")

If answer = vbNo Then
    MsgBox "Please Open Notes and Try the Macro Again"
    Exit Sub

Else

End If

Application.DisplayAlerts = False

Call Send

MsgBox "Mail Sent to " & (Range("L2").Value) & " " & "Recipents"

Application.DisplayAlerts = True

End Sub

Public Function Send()
      
    SendEMail = True

    Sheets("Main").Select
    
    TOID = Range("A7").Value
    CCID = ""
    SUBJ = Range("B7").Value
    'On Error GoTo ErrorMsg

    Dim EmailList As Variant
    Dim ws, uidoc, Session, db, uidb, NotesAttach, NotesDoc, objShell As Object
    Dim RichTextBody, RichTextAttachment As Object
    Dim server, mailfile, user, usersig As String
    Dim SubjectTxt, MsgTxt As String

    Set Session = CreateObject("Notes.NotesSession")
    user = Session.UserName
    usersig = Session.COMMONUSERNAME
    mailfile = Session.GETENVIRONMENTSTRING("MailFile", True)
    server = Session.GETENVIRONMENTSTRING("MailServer", True)

    Set db = Session.GETDATABASE(server, mailfile)
    
    If Not db.IsOpen Then
        Call db.Open("", "")
        Exit Function
    End If

    Set NotesDoc = db.CREATEDOCUMENT

    With NotesDoc
        .Form = "Memo"
        .Subject = SUBJ                          'The subject line in the email
        .Principal = user
        .sendto = TOID                           'e-mail ID variable to identify whom email need to be sent
        .CopyTo = CCID
    End With

    Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body")

    With NotesDoc
        .COMPUTEWITHFORM False, False
    End With

    '==Now set the front end stuff
    Set ws = CreateObject("Notes.NotesUIWorkspace")
    
    If Not ws Is Nothing Then
    
        Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)

        If Not uidoc Is Nothing Then
        
            If uidoc.EDITMODE Then
                
                'Mail Body
                Sheets("Main").Select
                Range("C7").Select
                Dim rnBody1 As Range
                Set rnBody1 = Selection
                rnBody1.CopyPicture
                
                'rnBody1.Copy
                Call uidoc.GOTOFIELD("Body")
                Call uidoc.Paste
            End If
            
        End If
        
    End If

    Call uidoc.Send
    Call uidoc.Close

    'close connection to free memory
    Set Session = Nothing
    Set db = Nothing
    Set NotesAttach = Nothing
    Set NotesDoc = Nothing
    Set uidoc = Nothing
    Set ws = Nothing

    Sheets("Main").Select

End Function

I think your send Function could be a procedure that you call with arguments. Those arguments can be variables that you assign in a loop over the A7 downwards range e.g. one argument would be passing Range("A"& currentRow) to the sub and within the sub assigning this to TOID, same column B and C values (you would pass these for current row.) This will be a slow i think. — QHarr, Nov 01 '17 at 07:21
Get rid of the .Select you are using. See [Avoiding .Select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). Use option explicit and check all your variables are declared and correctly typed e.g. Dim SendEmail As Boolean. You have a lot of variants e.g. Dim ws,.... NotesAttach, NotesDoc, objShell As Object, only the last is an object. You also have an empty Else clause. And i don't think in VBA you need the garbage collection at the end of your Function though others may disagree. — QHarr, Nov 01 '17 at 07:28
Hi QHarr, I am very new to these codes and does not understand it much. Can you please help me cleaning this code along with the looping option. — Amit, Nov 01 '17 at 07:56

QHarr · Answer 1 · 2017-11-01T08:21:12.037

I am worried about confusing you with too much new detail and must profess i haven't tested the following code so please don't assume this will solve your problem outright.

The following gives you an idea of how you might use a loop as you requested. See example also here which covers instances where you might need to batch send (admittedly link is for Outlook) and is also an example of using a loop.

I have included some explanations along the way in the code. It is difficult without more information to properly tailor this but i hope it helps.

Option Explicit

Public TOID As String
Public CCID As String
Public SECT As String
Public ACCO As String
Public SUBJ As String

Public Sub Send_Mail()

Dim wb As Workbook
Dim ws1 As Worksheet

Set wb = ThisWorkbook  'These are assumptions
Set ws1 = wb.Worksheets("Sheet1") 'These are assumptions. You would change as necessary

Dim answer As Long 'Integer types changed to Long

answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ??  Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES")

If answer = vbNo Then
    MsgBox "Please Open Notes and Try the Macro Again"
    Exit Sub

'Else 'Not being used so consider removing

End If

Application.DisplayAlerts = False

Dim lRow As Long
Dim loopRange As Range
Dim currentRow As Long
Dim TOIDvar As String
Dim SUBJvar As String

With ws1

    lRow = .Range("A7").End(xlDown).Row 'Assume no gaps in column A in the TOID range
    Set loopRange = .Range("A7:A" & lRow)

    For currentRow = 1 To loopRange.Rows.Count 'Loop range assigning values to arguments and call send sub with args

       TOIDvar = loopRange.Cells(currentRow, 1)

       SUBJvar = loopRange.Cells(currentRow, 1).Offset(0, 1) ' get column B in same row using Offset

       Send TOIDvar, SUBJvar

    Next currentRow


End With


'Commented out MsgBox at present as unsure what you will do when sending multiple e-mails
'MsgBox "Mail Sent to " & (ws1.Range("L2").Value) & " " & "Recipents" 'use explicit fully qualified Range references

Application.DisplayAlerts = True

End Sub

Public Sub Send(ByVal TOIDvar As String, ByVal SUBJvar As String) 'changed to sub using arguments

    Dim SendEMail As Boolean 'declare with type
    Dim wb As Workbook
    Dim ws2 As Worksheet

    Set wb = ThisWorkbook  'These are assumptions. Ensuring you are working with correct workbook
    Set ws2 = wb.Worksheets("Main")

    SendEMail = True
    TOID = TOIDvar
    CCID = vbNullString 'use VBNullString rather than empty string literals
    SUBJ = SUBJvar
    'On Error GoTo ErrorMsg

    Dim EmailList As Variant 'declaration of separate lines and with their types
    Dim ws As Object
    Dim uidoc As Object
    Dim Session As Object
    Dim db As Object
    Dim uidb As Object
    Dim NotesAttach As Object
    Dim NotesDoc As Object
    Dim objShell As Object
    Dim RichTextBody As Object
    Dim RichTextAttachment As Object
    Dim server As String
    Dim mailfile As String
    Dim user As String
    Dim usersig As String
    Dim SubjectTxt As String
    Dim MsgTxt As String

    Set Session = CreateObject("Notes.NotesSession")
    user = Session.UserName
    usersig = Session.COMMONUSERNAME
    mailfile = Session.GETENVIRONMENTSTRING("MailFile", True)
    server = Session.GETENVIRONMENTSTRING("MailServer", True)

    Set db = Session.GETDATABASE(server, mailfile)

    If Not db.IsOpen Then
        db.Open vbNullString, vbNullString
        Exit Sub
    End If

    Set NotesDoc = db.CREATEDOCUMENT

    With NotesDoc
        .Form = "Memo"
        .Subject = SUBJ                          'The subject line in the email
        .Principal = user
        .sendto = TOID                           'e-mail ID variable to identify whom email need to be sent
        .CopyTo = CCID
    End With

    Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body")

    With NotesDoc
        .COMPUTEWITHFORM False, False
    End With

    '==Now set the front end stuff
    Set ws = CreateObject("Notes.NotesUIWorkspace")

    If Not ws Is Nothing Then

        Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)

        If Not uidoc Is Nothing Then

            If uidoc.EDITMODE Then

                'Mail Body
                With ws2.Range("C7")
                    Dim rnBody1 As Range
                    Set rnBody1 = .Value2
                    rnBody1.CopyPicture

                'rnBody1.Copy
                    uidoc.GOTOFIELD "Body"
                    uidoc.Paste
                End With

            End If

        End If

    End If

    uidoc.Send
    uidoc.Close

    'removed garbage collection

    ws2.Activate ' swopped out .Select and used Worksheets collection held in variable ws2

End Sub

Thank you for the help, I tried running the code but i m getting Run Time error 424 at Set rnBody1 = .Value2 — Amit, Nov 01 '17 at 08:32
If you are setting to text within a cell then the rbBody1 should be a string variable and this line would be rnBody1 = .Value2 but i am unsure as you are then doing rnBody1.CopyPicture — QHarr, Nov 01 '17 at 08:35
The danger is this will become an extended debugging to meet your requirements. Focus perhaps just on getting the loop part working and come back with a specific question regarding the next problem you need to solve. — QHarr, Nov 01 '17 at 08:36

score 0 · Answer 2 · answered Nov 02 '17 at 03:58

You may want to consider this.

In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B and file name(s) in column C:Z it will create a mail with this information and send it.

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

See this link for all details.

https://www.rondebruin.nl/win/s1/outlook/amail6.htm

Loop function in VBA to send multiple emails

2 Answers2