I wonder if someone can help me.

I have a form from which I build a message which is sent to many recipients via email. I'm not using Outlook to transport the message because it requires a key click for each message sent.
Due to the nature of the message, I collect 50 email addresses at a time and mail the message on mass.
All works fine, except that when the Sub is complete, I am unable to close Access normally. I am required to force the program to close(CTRL/ALT/DELETE).
The code I use is copied bellow:

I kick off the function with:
    Call eMail_Marketing_Message(strSubject, strLine1, strLine2, strLine3, strLine4, strLine5, strLine6, strLine7, strLine8, strLine9, strLine0, strPromo1, strPromo2, strPromo3, emailall, Me.chkTest, BPTTBanner, MassMail)
----------------------------------------------------------------------------------------
Sub eMail_Marketing_Message(strSubject As String, strLine1, strLine2, strLine3, strLine4, strLine5, strLine6, strLine7, strLine8, strLine9, strLine0, strPromo1, strPromo2, strPromo3, emailall, Test As Boolean, BPTTBanner As String, MassMail As Boolean)
On Error GoTo Err_eMail_Marketing_Message

    Dim db As Database, inti As Integer
    Dim rec As Recordset, recAthlete As Recordset
    Dim strSQL As String, strBody As String, strAttachement As String, strEmailId As String, strMsg As String
    Dim strNewEmailID As String, intRecCount As Long, intTotalEmailed As Long, intTotalRecords As Long
    Dim dteStartDate As Date, dteEndDate As Date, dteStartTime As Date, dteEndTime As Date
    Dim strNotes As String

    dteStartDate = Format(Date, "Long Date")
    dteStartTime = Format(Time, "Long Time")

    Set db = CurrentDb()
    Set recAthlete = db.OpenRecordset("tblAthlete")

    DoCmd.SetWarnings False
    strSubject = strSubject
    strBody = "<IMG SRC='" & BPTTBanner & "' ALT='BPTT Banner'><BR/>"
    strBody = strBody & "<BR><BR> <B><I>" & strLine1 & "</B></I> <BR><BR>"
    If Not strLine2 = "" Then strBody = strBody & strLine2 & " <BR><BR>"
    If Not strLine3 = "" Then strBody = strBody & strLine3 & " <BR><BR>"
    If Not strLine4 = "" Then strBody = strBody & strLine4 & " <BR><BR>"
    If Not strLine5 = "" Then strBody = strBody & strLine5 & " <BR><BR>"
    If Not strLine6 = "" Then strBody = strBody & strLine6 & " <BR><BR>"
    If Not strLine7 = "" Then strBody = strBody & strLine7 & " <BR><BR>"
    If Not strLine8 = "" Then strBody = strBody & strLine8 & " <BR><BR>"
    If Not strLine9 = "" Then strBody = strBody & strLine9 & " <BR><BR>"
    If Not strLine0 = "" Then strBody = strBody & strLine0 & " <BR><BR>"
    If Not strPromo1 = "" Then strBody = strBody & "<I>" & strPromo1 & "</I> <BR><BR>"
    If Not strPromo2 = "" Then strBody = strBody & "<I>" & strPromo2 & "</I> <BR><BR>"
    If Not strPromo3 = "" Then strBody = strBody & "<I>" & strPromo3 & "</I>"

    strBody = strBody & "<BR><BR>" & "www.bptt.net"

    strSQL = "SELECT tblAthlete.FirstName, tblAthlete.LastName, tblAthlete.AthleteName, tblAthlete.eMailID, tblAthlete.OKtoMail, tblAthlete.RunBPTT " & _
        "From tblAthlete " & _
        "WHERE tblAthlete.eMailID Is Not Null And Not tblAthlete.eMailID = '' And tblAthlete.OKtoMail = True " & _
        "ORDER BY tblAthlete.AthleteName, tblAthlete.eMailID;"

    Set db = CurrentDb()
    Set rec = db.OpenRecordset(strSQL)

    recAthlete.MoveLast
    intTotalRecords = recAthlete.RecordCount
    recAthlete.MoveFirst

    inti = 0
    intRecCount = 0
    intTotalEmailed = 0
    While Not rec.EOF
        intRecCount = intRecCount + 1
        If emailall Then
            strEmailId = strEmailId & rec("EmailID") & ";"
            intTotalEmailed = intTotalEmailed + 1
            inti = inti + 1
        Else
            strEmailId = rec("EmailID")
            intTotalEmailed = intTotalEmailed + 1
            inti = inti + 1
            strNotes = "Individual added to email. Email number = " & intTotalEmailed
            Call LogDebug(rec("FirstName"), rec("LastName"), rec("EmailID"), dteStartDate, dteEndDate, dteStartTime, dteEndTime, strNotes)
        End If
        If Not MassMail Then
            strNotes = "Start of individual mass mail. EMail number = " & intTotalEmailed
            Call LogDebug(rec("FirstName"), rec("LastName"), rec("EmailID"), dteStartDate, dteEndDate, dteStartTime, dteEndTime, strNotes)
            Call EmailRoutine(strEmailId, strBody, strSubject, Test)
            MsgBox "Email Sent - " & strSubject
            strNotes = "End of individual mass mail. EMail number = " & intTotalEmailed
            Call LogDebug(rec("FirstName"), rec("LastName"), rec("EmailID"), dteStartDate, dteEndDate, dteStartTime, dteEndTime, strNotes)
            strEmailId = ""
            MsgBox ("number of athletes emailed so far = " & intTotalEmailed & " out of " & intTotalRecords)
            inti = 0
        Else
            If inti > 49 Then
                strNotes = "Start of collective mass mail. EMail number = " & intTotalEmailed
                Call LogDebug(rec("FirstName"), rec("LastName"), rec("EmailID"), dteStartDate, dteEndDate, dteStartTime, dteEndTime, strNotes)
                Call EmailRoutine(strEmailId, strBody, strSubject, Test)
                MsgBox "Email Sent - " & strSubject
                strNotes = "End of collective mass mail. EMail number = " & intTotalEmailed
                Call LogDebug(rec("FirstName"), rec("LastName"), rec("EmailID"), dteStartDate, dteEndDate, dteStartTime, dteEndTime, strNotes)
                strEmailId = ""
                MsgBox ("number of athletes emailed so far = " & intTotalEmailed & " out of " & intTotalRecords)
                inti = 0
            End If
        End If
        rec.MoveNext
    Wend
    If rec.EOF Then
        MsgBox "no more records to email"
    End If
    If inti > 0 And inti < 50 Then
        strNotes = "Start of marketing mail. EMail number = " & intTotalEmailed
        Call LogDebug("FirstName", "LastName", "EmailID", dteStartDate, dteEndDate, dteStartTime, dteEndTime, strNotes)
        Call EmailRoutine(strEmailId, strBody, strSubject, Test)
        MsgBox "Email Sent - " & strSubject
        strNotes = "End of marketing mail. eMail number = " & intTotalEmailed
        Call LogDebug("Last Record", "", "", dteStartDate, dteEndDate, dteStartTime, dteEndTime, strNotes)
        'MsgBox ("number of athletes emailed so far = " & intTotalEmailed & " out of " & intTotalRecords)
        inti = 1
    End If
    MsgBox ("Total number of athletes emailed = " & intTotalEmailed & " out of " & intTotalRecords)

    rec.Close
    Set rec = Nothing
    DoCmd.SetWarnings True

Exit_eMail_Marketing_Message:
    Exit Sub

Err_eMail_Marketing_Message:
    MsgBox Err.Description
    ErrorLog 1234, Err.Description, Err.Source
    Resume Exit_eMail_Marketing_Message

End Sub
----------------------------------------------------------------------------------------
Function EmailRoutine(strRecipient As String, strBody As String, strSubject As String, Test As Boolean)
On Error GoTo Err_EmailRoutine

    Dim ObjMail As CDO.Message
    Dim PauseTime As Date, Start As Date, Finish As Date

    Set ObjMail = New CDO.Message
    ObjMail.From = "Bushy Park Time Trial <[email protected]>"
    ObjMail.CC = "[email protected]"
    'All mail sent to Blind Copy and not directly to recipient
    'ObjMail.To = strRecipient
    ObjMail.BCC = strRecipient
    ObjMail.Subject = strSubject
    ObjMail.HTMLBody = strBody
    'ObjMail.MimeFormatted

    Dim Config As CDO.Configuration
    Set Config = New CDO.Configuration

    'Configuration:
    'config.Fields(CDO.cdoSendUsingMethod) = CDO.cdoSendUsingPickup
    Config.Fields(CDO.cdoSendUsingMethod) = CDO.cdoSendUsingPort
    Config.Fields(CDO.cdoSMTPServer) = "mail.bptt.net"
    Config.Fields(CDO.cdoSMTPServerPort) = 25
    Config.Fields(CDO.cdoSMTPAuthenticate) = CDO.cdoBasic
    Config.Fields(CDO.cdoSendUserName) = "[email protected]"
    Config.Fields(CDO.cdoSendPassword) = "morgan"

    'Update configuration
    Config.Fields.Update
    Set ObjMail.Configuration = Config
    'for test purposes only
    If Test Then
        ObjMail.To = "TEST <[email protected]>"
        ObjMail.CC = "[email protected]"
        ObjMail.BCC = ""
    End If

    ObjMail.Send

    If Not Test Then
        'Take a break
        PauseTime = 1 ' Set duration.
        Start = Timer ' Set start time.
        'Do While Timer < Start + PauseTime
        DoEvents ' Yield to other processes.
        'Loop
        Finish = Timer
    End If

    Set ObjMail = Nothing
    Set Config = Nothing
    Exit Function

Exit_EmailRoutine:
    '
    '
    '
    Exit Function

Err_EmailRoutine:
' Raise an appropriate error
    strSource = " EmailRoutine"
    If Not Err.Description = "" Then
        StrDesc = Err.Description
        syserrorNum = Err.Number
        strSource = Err.Source & strSource
    End If
    'Err.Raise syserrorNum, strSource, StrDesc
    ErrorLog syserrorNum, StrDesc, strSource
    Debug.Print "Email failed"
    If syserrorNum = -2147220977 Then
        Debug.Print "Problem with e-mail address - " & strRecipient
    End If
    If syserrorNum = -2147220973 Then
        Debug.Print "Problem connecting to email server"
        Debug.Print "End the process and try again later"
    End If
        Stop
        'exit function
    '
    On Error Resume Next
        'Set Start = Nothing
        Set Config = Nothing
        Set ObjMail = Nothing
        If Not Err.Description = "" Then
            MsgBox Err.Description, , "Error in " & strSource & " - " & Err.Number
        End If
    Resume Exit_EmailRoutine
    'Resume 0 '.FOR TROUBLESHOOTING
End Function

Paul

__________________
Paul

It sounds like you are stuck in a loop somewhere. You might start by getting rid of this:

 If rec.EOF Then
        MsgBox "no more records to email"
    End If

Change to:

MsgBox "no more records to email"

Since rec.EOF is already true if the While Wend finishes.

See if you get this message next time. Or do you get it now?

mmcdonal

Thanks mmcdonal,

I do get the message now, but you're quite right the EOF check is superfluous...

The strange thing is, that if I send an email, one at a time, I dont get this condition. The second strange thing is that when i quit the application, all references to my database close but Access stays open. So, all objects within Access seem to disappear but the shell remails active until I force a close.

Paul

Paul