Link to home
Start Free TrialLog in
Avatar of mlittler
mlittler

asked on

implementing loop funtion

I have some code (below) which sends generates email in outlook.

Problem is that I want it to generate a new email for each recipient in a list box "lstSendSelections".

At the moment I have a loop function, but where I have modified this from some other code it is still putting more than one recipient in the "to" field of the Outlook email. That's because of this piece of code...

    For Each itm In lst1.ItemsSelected
        Set objOutlookRecip = .Recipients.Add(lst1.Column(2, itm))
        objOutlookRecip.Type = olTo

Problem is that I don't know how to modify it so that it puts one recipient in, goes through the code and generates an email and then goes through the code again from the beginning for the next recipient.



<CODE STARTS>

Public Sub MailMergeEmail()

Dim EmailType As Variant
Dim lst1 As ListBox
Dim itm As Variant
Dim dteSent As Date
Dim strSubject As String
Dim strMessage As String
Dim strProductRef As String
Dim strEmployeeID As String
Dim strAttached As String
Dim strAttachments As String
Dim intAttachmentNumber As Integer
Dim intLoop As Integer
Dim boSendAnother As Boolean
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim db As Database
Dim rs As Recordset

On Error GoTo err_MailMergeEmail

    Set db = CurrentDb()
    Set rs = db.OpenRecordset("CustomerComms")
   
    Set lst1 = Me.lstSendSelections

    strSubject = "" & Me!EmailSubject
    strMessage = "" & Me!CommsNotes
    strProductRef = "" & Me!ProductRef
    strEmployeeID = "" & Me!EmployeeID
   
     
    Do Until intLoop = lst1.ListCount    ' Select every item in the "To" list box
    intLoop = intLoop + 1
                       
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
    ' Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    With objOutlookMsg
        'Set the Subject, Body, and
        .Subject = strSubject
        .Body = strMessage & vbCrLf & vbCrLf
       
    ' ## This part needs changing, because it is selecting all the recipients in the listbox
    For Each itm In lst1.ItemsSelected
        Set objOutlookRecip = .Recipients.Add(lst1.Column(2, itm))
        objOutlookRecip.Type = olTo

        ' Add attachments to the message.
        If MsgBox("Do you want to add an Attachment?", 36) = vbYes Then
            boSendAnother = True
        Else
            boSendAnother = False
        End If
        Do Until boSendAnother = False
            strAttached = ahtCommonFileOpenSave()
            intAttachmentNumber = intAttachmentNumber + 1
            strAttachments = strAttachments & "Attachment " & intAttachmentNumber & " ~ " & strAttached
            Set objOutlookAttach = .Attachments.Add(strAttached)
            If MsgBox("Do you want to add another attachment?", 36) = vbNo Then
                boSendAnother = False
            End If
        Loop

        dteSent = Now()

            rs.AddNew
            rs!CommsDate = dteSent
            rs!ContactID2 = lst1.Column(0, itm)
            rs!ProductRef = strProductRef
            rs!EmployeeCustComs = strEmployeeID
            rs!CommsNotes = strMessage
            rs!EmailSubject = strSubject
            rs!EmailAttach = "" & strAttachments
            rs!SentTo = lst1.Column(2, itm)
            rs.Update
    Next itm

        If Me.opSendNow Then ' Should we display the message before sending?
            .Send
            '.Save
        Else
            .Display
        End If
    End With
   
    If lst1.ListCount < intLoop Then Exit Do
       lst1.Selected(intLoop - 1) = True
    Loop
   
    Set objOutlook = Nothing
   
err_MailMergeEmail_Exit:
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Exit Sub

err_MailMergeEmail:

    Select Case Err.Number
        Case 2501   ' User canceled sending
        Case 287
            MsgBox "Email canceled or Access denied"
        Case Else
        MsgBox Err.Number & " ~ " & Err.Description
    End Select

    Resume err_MailMergeEmail_Exit

End Sub
Avatar of jadedata
jadedata
Flag of United States of America image

Hey mlittler!
This section:
        ' Add attachments to the message.
        If MsgBox("Do you want to add an Attachment?", 36) = vbYes Then
            boSendAnother = True
        Else
            boSendAnother = False
        End If
        Do Until boSendAnother = False
            strAttached = ahtCommonFileOpenSave()
            intAttachmentNumber = intAttachmentNumber + 1
            strAttachments = strAttachments & "Attachment " & intAttachmentNumber & " ~ " & strAttached
            Set objOutlookAttach = .Attachments.Add(strAttached)
            If MsgBox("Do you want to add another attachment?", 36) = vbNo Then
                boSendAnother = False
            End If
        Loop

Can be changed to:  (same operation, less code, more compact)
        ' Add attachments to the message.
        boSendAnother=MsgBox("Do you want to add an Attachment?", vbyesno+vbquestion,"Attachments Anyone?")
        Do Until boSendAnother = vbno
            strAttached = ahtCommonFileOpenSave()
            intAttachmentNumber = intAttachmentNumber + 1
            strAttachments = strAttachments & "Attachment " & intAttachmentNumber & " ~ " & strAttached
            Set objOutlookAttach = .Attachments.Add(strAttached)
            boSendAnother=MsgBox("Do you want to add another attachment?", vbyesno+vbquestion,"Attachments Anyone?")
        Loop

What is the purpose of this section:??
    If lst1.ListCount < intLoop Then Exit Do
       lst1.Selected(intLoop - 1) = True
    Loop

Note:  your indents are inconsistant with the "nesting level" of some operations.  The above section:  the IF line appears to be at the same "nest level" as the loop.  This makes the code a little harder to decipher.  (just a thought...)

I think this line:
  If lst1.ListCount < intLoop Then Exit Do
is your party killer...

See next commment:

regards
Jack
Public Sub MailMergeEmail()

  Dim EmailType As Variant
  Dim lst1 As ListBox
  Dim itm As Variant
  Dim dteSent As Date
  Dim strSubject As String
  Dim strMessage As String
  Dim strProductRef As String
  Dim strEmployeeID As String
  Dim strAttached As String
  Dim strAttachments As String
  Dim intAttachmentNumber As Integer
  Dim intLoop As Integer
  Dim boSendAnother As Boolean
  Dim objOutlook As Outlook.Application
  Dim objOutlookMsg As Outlook.MailItem
  Dim objOutlookRecip As Outlook.Recipient
  Dim objOutlookAttach As Outlook.Attachment
  Dim db As Database
  Dim rs As Recordset

  On Error GoTo err_MailMergeEmail

  Set db = CurrentDb()
  Set rs = db.OpenRecordset("CustomerComms")
   
  Set lst1 = Me.lstSendSelections

  strSubject = "" & Me!EmailSubject
  strMessage = "" & Me!CommsNotes
  strProductRef = "" & Me!ProductRef
  strEmployeeID = "" & Me!EmployeeID
     
  ' Create the Outlook session.
  Set objOutlook = CreateObject("Outlook.Application")
  ' Create the message.
  Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
  With objOutlookMsg
    'Set the Subject, Body, and
    .Subject = strSubject
    .Body = strMessage & vbCrLf & vbCrLf
       
    For Each itm In lst1.ItemsSelected
      Set objOutlookRecip = .Recipients.Add(lst1.Column(2, itm))
      objOutlookRecip.Type = olTo

      ' Add attachments to the message.
      boSendAnother=MsgBox("Do you want to add an Attachment?", vbyesno+vbquestion,"Attachments Anyone?")
      Do Until boSendAnother = vbno
        strAttached = ahtCommonFileOpenSave()
        intAttachmentNumber = intAttachmentNumber + 1
        strAttachments = strAttachments & "Attachment " & intAttachmentNumber & " ~ " & strAttached
        Set objOutlookAttach = .Attachments.Add(strAttached)
        boSendAnother=MsgBox("Do you want to add another attachment?", vbyesno+vbquestion,"Attachments Anyone?")
      Loop

      dteSent = Now()

      'record email sent
      rs.AddNew
      rs!CommsDate = dteSent
      rs!ContactID2 = lst1.Column(0, itm)
      rs!ProductRef = strProductRef
      rs!EmployeeCustComs = strEmployeeID
      rs!CommsNotes = strMessage
      rs!EmailSubject = strSubject
      rs!EmailAttach = "" & strAttachments
      rs!SentTo = lst1.Column(2, itm)
      rs.Update

      If Me.opSendNow Then ' Should we display the message before sending?
        .Send
        '.Save
      Else
        .Display
      End If

    Next itm    '<this line was out of place in the nesting

  End With 'objOutlookMsg
   
  Set objOutlook = Nothing
   
err_MailMergeEmail_Exit:
  on error resume next
  rs.Close: Set rs = Nothing
  db.close: Set db = Nothing
  Exit Sub

err_MailMergeEmail:
  Select Case Err.Number
  Case 287,2501
    Resume err_MailMergeEmail_Exit
  Case Else
    MsgBox Err.Number & " ~ " & Err.Description
    Resume err_MailMergeEmail_Exit
    resume
  End Select

End Sub
Avatar of heer2351
heer2351

Try this:

Public Sub MailMergeEmail()

Dim EmailType As Variant
Dim lst1 As ListBox
Dim itm As Variant
Dim dteSent As Date
Dim strSubject As String
Dim strMessage As String
Dim strProductRef As String
Dim strEmployeeID As String
Dim strAttached As String
Dim strAttachments As String
Dim intAttachmentNumber As Integer
Dim boSendAnother As Boolean
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim db As Database
Dim rs As Recordset

On Error GoTo err_MailMergeEmail

    Set db = CurrentDb()
    Set rs = db.OpenRecordset("CustomerComms")
   
    Set lst1 = Me!lstSendSelections

    strSubject = "" & Me!EmailSubject
    strMessage = "" & Me!CommsNotes
    strProductRef = "" & Me!ProductRef
    strEmployeeID = "" & Me!EmployeeID
   
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
   
    ' Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    With objOutlookMsg
      'Set the Subject, Body, and
      .Subject = strSubject
      .Body = strMessage & vbCrLf & vbCrLf
     
      ' Add attachments to the message.
      If MsgBox("Do you want to add an Attachment?", 36) = vbYes Then
          boSendAnother = True
      Else
          boSendAnother = False
      End If
     
      Do Until boSendAnother = False
          strAttached = ahtCommonFileOpenSave()
          intAttachmentNumber = intAttachmentNumber + 1
          strAttachments = strAttachments & "Attachment " & intAttachmentNumber & " ~ " & strAttached
          Set objOutlookAttach = .Attachments.Add(strAttached)
          If MsgBox("Do you want to add another attachment?", 36) = vbNo Then
              boSendAnother = False
          End If
      Loop
   
      'Now send the item to all selected recipients, one by one
      For Each itm In lst1.ItemsSelected
        dteSent = Now()
 
        rs.AddNew
        rs!CommsDate = dteSent
        rs!ContactID2 = lst1.Column(0, itm)
        rs!ProductRef = strProductRef
        rs!EmployeeCustComs = strEmployeeID
        rs!CommsNotes = strMessage
        rs!EmailSubject = strSubject
        rs!EmailAttach = "" & strAttachments
        rs!SentTo = lst1.Column(2, itm)
        rs.Update
 
        'Clear any previous recipients
        .Recipients = Nothing
       
        'Add the current
        Set objOutlookRecip = .Recipients.Add(lst1.Column(2, itm))
        objOutlookRecip.Type = olTo
       
        If Me!opSendNow Then ' Should we display the message before sending?
            .Send
            '.Save
        Else
            .Display
        End If
      Next itm
    End With
   
    Set objOutlookMsg = Nothing
    Set objOutlook = Nothing
   
err_MailMergeEmail_Exit:
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Exit Sub

err_MailMergeEmail:

    Select Case Err.Number
        Case 2501   ' User canceled sending
        Case 287
            MsgBox "Email canceled or Access denied"
        Case Else
        MsgBox Err.Number & " ~ " & Err.Description
    End Select

    Resume err_MailMergeEmail_Exit

End Sub

Spotted a small problem in my previous code.

Please add back intLoop variable in the declarations:

Dim intLoop As Integer

and replace

        'Clear any previous recipients
        .Recipients = Nothing

with:

        'Clear any previous recipients
        For intLoop = 0 To .Recipients.Count - 1
          .Recipients.Remove (intLoop + 1)
        Next
this any good?
<CODE STARTS>

Public Sub MailMergeEmail()

Dim EmailType As Variant
Dim lst1 As ListBox
Dim itm As Variant
Dim dteSent As Date
Dim strSubject As String
Dim strMessage As String
Dim strProductRef As String
Dim strEmployeeID As String
Dim strAttached As String
Dim strAttachments As String
Dim intAttachmentNumber As Integer
Dim intLoop As Integer
Dim boSendAnother As Boolean
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim db As Database
Dim rs As Recordset

On Error GoTo err_MailMergeEmail

    Set db = CurrentDb()
    Set rs = db.OpenRecordset("CustomerComms")
   
    Set lst1 = Me.lstSendSelections

    strSubject = "" & Me!EmailSubject
    strMessage = "" & Me!CommsNotes
    strProductRef = "" & Me!ProductRef
    strEmployeeID = "" & Me!EmployeeID
   
     
    Do Until intLoop = lst1.ListCount    ' Select every item in the "To" list box
    intLoop = intLoop + 1
                       
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")

'
' move the msg creation into the loop  do it once for each item
       
    ' ## This part needs changing, because it is selecting all the recipients in the listbox
    For Each itm In lst1.ItemsSelected
    ' Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    With objOutlookMsg
        'Set the Subject, Body, and
        .Subject = strSubject
        .Body = strMessage & vbCrLf & vbCrLf

        Set objOutlookRecip = .Recipients.Add(lst1.Column(2, itm))
        objOutlookRecip.Type = olTo

        ' Add attachments to the message.
        If MsgBox("Do you want to add an Attachment?", 36) = vbYes Then
            boSendAnother = True
        Else
            boSendAnother = False
        End If
        Do Until boSendAnother = False
            strAttached = ahtCommonFileOpenSave()
            intAttachmentNumber = intAttachmentNumber + 1
            strAttachments = strAttachments & "Attachment " & intAttachmentNumber & " ~ " & strAttached
            Set objOutlookAttach = .Attachments.Add(strAttached)
            If MsgBox("Do you want to add another attachment?", 36) = vbNo Then
                boSendAnother = False
            End If
        Loop

        dteSent = Now()

            rs.AddNew
            rs!CommsDate = dteSent
            rs!ContactID2 = lst1.Column(0, itm)
            rs!ProductRef = strProductRef
            rs!EmployeeCustComs = strEmployeeID
            rs!CommsNotes = strMessage
            rs!EmailSubject = strSubject
            rs!EmailAttach = "" & strAttachments
            rs!SentTo = lst1.Column(2, itm)          '## do you want this to contain 1 or all ids?
            rs.Update
   '## Next itm   move this...

        If Me.opSendNow Then ' Should we display the message before sending?
            .Send
            '.Save
        Else
            .Display
        End If
'
' ## ok destroy the current obj
' and create a new one..
'
      Set objOutlookmsg = Nothing
     Next itm

    End With
 
   Set objOutlook = Nothing

    With Lst1
    If .ListCount < intLoop Then Exit Do
       .Selected(intLoop - 1) = True
    Loop
    end with

   
err_MailMergeEmail_Exit:
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Exit Sub

err_MailMergeEmail:

    Select Case Err.Number
        Case 2501   ' User canceled sending
        Case 287
            MsgBox "Email canceled or Access denied"
        Case Else
        MsgBox Err.Number & " ~ " & Err.Description
    End Select

    Resume err_MailMergeEmail_Exit

End Sub



but i agree with Jade that you need to be more consistent with your indents ...
and use his simplication for the message box...

looking at the code I unclear wether you are wantint to send the same message to all recipients
or as at present each recipient get ther own message...
Avatar of mlittler

ASKER

The purpose of the code is to generate an individual email for each of the receipients, but with the same properties (subject, body and attachments).

unfortunately none of your suggestions seem to work! The code jumps from...

For Each itm In lst1.ItemsSelected


to this line...

Set objOutlookMsg = Nothing
You have to have the items selected.  this is the purpose of the For Each itm line in the code

If you want it to ignore selections:

  For itm = 0 to lst1.listcount-1
My code is setup such that it will indeed send the same message including the attachements to all selected recipients. If you want to send it to everyone listed in the listbox change:

For Each itm In lst1.ItemsSelected

to

For itm = 0 to lst1.listcount-1

like jadedata already stated.

Thanks.

I made the change, but it is not creating two messages (I tested it with two recipients).

Because the code to create a new message, etc is not in the loop, it simply creates the message with the first email address in the list, and then loops round and changes the recipient of the email two the second email address in the list.

If I put the line...

For itm = 0 to lst1.listcount-1

before the code to create a message in Outlook, it does not compile properly, as the line noted below is shown as a "Next without For" - I don't think it likes nested For...Next statements!


        If Me!opSendNow Then ' Should we display the message before sending?
            .Send
            '.Save
        Else
            .Display
        End If
      Next itm  '<<<<< this line here is highlighted!
    End With
You should remove the itm after the next to get rid of the compile error.

However I just did a better test of my code and it does not work as I expected, I do not have time right now but will fix it later this evening.
thanks!
ASKER CERTIFIED SOLUTION
Avatar of heer2351
heer2351

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Thanks. It works well, except that I forgot to tell you the purpose of this script; it is to substitute a tag "[Name]" which is written in the body of the message with the recipient's name.

      If InStr(strMessage, "[Name]") > 0 Then
    strMessage = Replace(strMessage, "[Name]", DLookup("[FirstName]", "[CUSTOMERS]", "[Email]='" & lst1.Column(2, itm) & "'"))
    Else
    End If


The problem is with your .copy method the body of the email cannot be altered, or is there a way to do this?
>> The purpose of the code is to generate an individual email for each of the receipients, but with the same properties (subject, body and attachments).

But the body can be changed right after the copy:

      'Make a copy of the mail
      Set objOutlookMsg = objOutlookMsgOriginal.Copy
      objOutlookMsg.body = strMessage

Make sure you change the strMessage before you update to the table, otherwise you will get the wrong message in the field commsNotes
Thanks.

I have worked out exactly what the problem is now....

If in the email body i have the tag "[Name]" it goes through the first loop and replaces it with the first recipients name using this code...

      'Make a copy of the mail
      Set objOutlookMsg = objOutlookMsgOriginal.Copy
      If InStr(strMessage, "[Name]") > 0 Then
    strMessage = Replace(strMessage, "[Name]", DLookup("[FirstName]", "[CUSTOMERS]", "[Email]='" & lst1.Column(2, itm) & "'"))
    Else
    End If
      objOutlookMsg.Body = strMessage


The problem is that when it loops around again, the strMessage value has been set to the first recipient's name and so it cannot find the "[Name]" tag anymore!

Now, you would think that by setting the value back to the original source at the end of the 'loop', thus...

          objOutlookMsg.Display
      End If
     
      Set objOutlookMsg = Nothing
      strMessage = "" & Me!CommsNotes
     
    Next


...it would work. But it generates an error when it goes into the script to do the replace function the second time around. This is the code for the replace function...

Function Replace(ByVal strText As String, strOld As String, strNew As String) As String
Dim intSt As Integer, intOldLen As Integer, intNewLen As Integer
Dim strTemp As String
Dim intVal As Integer

    strTemp = strText
    intOldLen = Len(strOld)
    intNewLen = Len(strNew)
    intSt = InStr(strText, strOld)
    Do Until intSt = 0
        strTemp = Left$(strTemp, intSt - 1) & strNew & Mid$(strTemp, intSt + intOldLen)
        intVal = intSt + intNewLen - intOldLen + 1
        If intVal < 0 Then intVal = 1
        intSt = InStr(intVal, strTemp, strOld)
    Loop

    Replace = strTemp
   
End Function

On the line         intSt = InStr(intVal, strTemp, strOld)

it fails and generates the error; "5~ invalid procedure call or argument".

Stepping through the code I cannot understand the problem!
Actually I suspected as much, but thought that it could not be so ridiculous - it is failing when the second recipient's name is shorter than the first one!


This line...
If intVal < 0 Then intVal = 1


needed to be changed to <= 0

!

Thanks for all your help. I will award the points!