locked
My vba code is sending continuous emails?? RRS feed

  • Question

  • I finally got my vba code to send emails but now it sends emails non stop, until I do a force stop. Please find where this is doing this. I can't figure it out.

    Carlo Vega

    On Error GoTo MailError

    Dim bStarted As Boolean
    Dim oOutlookApp As Object
    Dim oItem As Object
    Dim rst As DAO.Recordset
    Dim strTbl As String
    Dim strMsg As String
    Dim iGFRN As String
    Dim iBreakType As String

    Set rst = CurrentDb.OpenRecordset("select * from [MASTER EXCEPTION LIST];")

    Set oOutlookApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        'Outlook wasn't running, start it from code
        Set oOutlookApp = CreateObject("Outlook.Application")
        bStarted = True
    End If
         
    Me.TxtGfrn.SetFocus
    iGFRN = Me.TxtGfrn.Text
    Me.txtTempBreakType.Visible = True
    Me.txtTempBreakType.SetFocus
    iBreakType = Me.txtTempBreakType.Text
    Me.TxtGfrn.SetFocus
    Me.txtTempBreakType.Visible = False

    If Not (rst.EOF And rst.BOF) Then
        rst.MoveFirst
        Do Until rst.EOF = True
        If iGFRN = rst("[GFRN NUMBER]") Then
            If iBreakType = rst("[BREAK TYPE]") Then
               
                    strMsg = "GFRN #: " & rst("[GFRN NUMBER]") & vbCrLf & _
                    "Date of Break: " & rst("[BREAK DATE]") & vbCrLf & vbCrLf & _
                     "Facility: " & rst("[CUSTOMER NAME]") & vbCrLf & _
                    "CRA: " & rst("[CRA RESPONSIBLE]") & vbCrLf & _
                    "Break Reason: " & rst("[BREAK TYPE]") & vbCrLf & _
                    "Owner: " & rst("[BREAK RESPONSIBILITY]") & vbCrLf & _
                    "Break Status: " & rst("[BREAK STATUS]") & vbCrLf & vbCrLf & _
                    "Exception Reason:" & rst("[EXCEPTION REASON]") & vbCrLf & vbCrLf & _
                    "CRMS Comments: " & rst("[COMMENTS CRMS]") & vbCrLf & _
                    "ORIG Comments: " & rst("[COMMENTS ORIG]")
                       
                    rst.MoveLast
                    'Create new mail item
                    Const olMailItem = 0
                    Set oItem = oOutlookApp.CreateItem(olMailItem)
                     
                    With oItem
                        'Set the recipient for the new email
                        .To = "*GL US Reporting Team" & ";"
                        '.CC = "*ICG US CRMS Portfolio Services "
                        .Subject = "EMEA Rapid to FLEX Exception Request: " & TxtGfrn
                        '.Attachments.Add
                        .Body = strMsg
                        .Display
                    End With
            Else
                rst.MoveNext
            End If
        Else
            rst.MoveNext
        End If
        Loop
    End If
     
    'Clean up
    rst.Close

    Set rst = Nothing
    Set oItem = Nothing
    Set oOutlookApp = Nothing

    ExitMailErr:
        Exit Sub

    MailError:
        MsgBox Err.Description
        GoTo ExitMailErr

    Monday, March 7, 2016 6:55 PM

All replies

  • after you display the message you need to then move to the next record

    With oItem 'Set the recipient for the new email .To = "*GL US Reporting Team" & ";" '.CC = "*ICG US CRMS Portfolio Services " .Subject = "EMEA Rapid to FLEX Exception Request: " & TxtGfrn '.Attachments.Add .Body = strMsg .Display End With

    rst.MoveNext 'ADD THIS LINE



    Brian, ProcessIT- Hawke`s Bay, New Zealand

    Tuesday, May 31, 2016 1:58 AM