Wrox Programmer Forums

Need to download code?

View our list of code downloads.

Go Back   Wrox Programmer Forums > Microsoft Office > Access and Access VBA > Access VBA
Password Reminder
Register
| FAQ | Members List | Calendar | Search | Today's Posts | Mark Forums Read
Access VBA Discuss using VBA for Access programming.
Welcome to the p2p.wrox.com Forums.

You are currently viewing the Access VBA section of the Wrox Programmer to Programmer discussions. This is a community of tens of thousands of software programmers and website developers including Wrox book authors and readers. As a guest, you can read any forum posting. By joining today you can post your own programming questions, respond to other developers’ questions, and eliminate the ads that are displayed to guests. Registration is fast, simple and absolutely free .
DRM-free e-books 300x50
Reply
 
Thread Tools Search this Thread Display Modes
  #1 (permalink)  
Old December 29th, 2005, 08:44 AM
Authorized User
 
Join Date: Sep 2004
Location: Twickenham, , United Kingdom.
Posts: 20
Thanks: 0
Thanked 0 Times in 0 Posts
Send a message via MSN to Paulsh Send a message via Yahoo to Paulsh
Default Access locks up after multiple emails sent

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 <paul@bptt.net>"
    ObjMail.CC = "paul@bptt.net"
    '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) = "paul@bptt.net"
    Config.Fields(CDO.cdoSendPassword) = "morgan"

    'Update configuration
    Config.Fields.Update
    Set ObjMail.Configuration = Config
    'for test purposes only
    If Test Then
        ObjMail.To = "TEST <paul@bptt.net>"
        ObjMail.CC = "paul@bptt.net"
        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
Reply With Quote
  #2 (permalink)  
Old December 29th, 2005, 01:03 PM
Friend of Wrox
Points: 9,611, Level: 42
Points: 9,611, Level: 42 Points: 9,611, Level: 42 Points: 9,611, Level: 42
Activity: 0%
Activity: 0% Activity: 0% Activity: 0%
 
Join Date: Mar 2004
Location: Washington, DC, USA.
Posts: 3,069
Thanks: 0
Thanked 10 Times in 10 Posts
Default

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
Reply With Quote
  #3 (permalink)  
Old December 30th, 2005, 03:20 PM
Authorized User
 
Join Date: Sep 2004
Location: Twickenham, , United Kingdom.
Posts: 20
Thanks: 0
Thanked 0 Times in 0 Posts
Send a message via MSN to Paulsh Send a message via Yahoo to Paulsh
Default

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
Reply With Quote
Reply


Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is Off
HTML code is Off
Trackbacks are Off
Pingbacks are On
Refbacks are Off


Similar Threads
Thread Thread Starter Forum Replies Last Post
Multiple emails validation in one text box with co kumiko Javascript 5 February 7th, 2008 05:49 AM
Multiple emails with one DTS package ninel SQL Server DTS 1 October 23rd, 2006 08:00 AM
Auto Emails From Access SparrowCathy Access 6 April 6th, 2006 08:14 PM
Locks on my access db in win xp patricolsson Classic ASP Databases 6 December 17th, 2003 09:31 AM
¿Record Locks? Concurrency Multiple Users p_nut33 ADO.NET 0 November 18th, 2003 10:02 AM



All times are GMT -4. The time now is 06:22 PM.


Powered by vBulletin®
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
© 2013 John Wiley & Sons, Inc.