Categories

See More
Popular Forum

MBA (4887) B.Tech (1769) Engineering (1486) Class 12 (1030) Study Abroad (1004) Computer Science and Engineering (988) Business Management Studies (865) BBA (846) Diploma (746) CAT (651) B.Com (648) B.Sc (643) JEE Mains (619) Mechanical Engineering (574) Exam (525) India (462) Career (452) All Time Q&A (439) Mass Communication (427) BCA (417) Science (384) Computers & IT (Non-Engg) (383) Medicine & Health Sciences (381) Hotel Management (373) Civil Engineering (353) MCA (349) Tuteehub Top Questions (348) Distance (340) Colleges in India (334)
See More
( 7 months ago )

MS Access While Loop Skips first record

Course Queries Syllabus Queries
Max. 2000 characters
Replies

usr_profile.png
Shiv Thapa

User

( 7 months ago )


I have a split multi-user MS Access (2013 ACCDE file) database that is used to email out class schedules and syllabi to professors. The end user presses a button on a form when they are ready to send emails and then the DB has code that cycles through each entry (about 70) in a filtered datasheet within a subform. Generally, the code to add attachments and to send email works... However, with how the code is set below, the last person on the email list gets emailed twice... they are both the first and the last person the DB sends an email to...

I've included my pertinent code below. As always I'm greatly appreciative of any assistance you can offer.

Private Sub SchedEmailButton_Click()

    Me.FacEmailingList2.SetFocus
    RunCommand acCmdRecordsGoToLast  'I've tried moving this and the next line of code to the "Sub Form_Current" (See below) but then the application just blinks and does nothing
    RunCommand acCmdRecordsGoToFirst

Alternatively, I've tried this as well for the button, which is when only the first record gets skipped (Thus my post title):

Private Sub SchedEmailButton_Click()

    Dim rst As DAO.Recordset

    Me.FacEmailingList2.SetFocus 
        While Not rst.EOF
        rst.MoveNext
        Wend
        Set rst = Nothing

This is the code that loops through the list of email recipients, stripped down (edited) to really what matters due to its length:

Private Sub Form_Current()

[Set Variables]

        'RunCommand acCmdRecordsGoToLast  'This causes the email automation code to fail
        'RunCommand acCmdRecordsGoToFirst
        While Me.CurrentRecord <= Me.Recordset.RecordCount
[Working Loop Code Area]
        Wend

[EDIT]This is the full code (just in case):

Private Sub Form_Current()

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFiltered As DAO.Recordset
Dim WhereSem As String
Dim WhereYear As String
Dim WhereFac As String
Dim WSemq As String
Dim WYearq As String
Dim WFacq As String
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objOutlookRecip As Object
Dim objOutlookAttach As Object
Dim docuser As String
Dim docpath1 As String
Dim docpath2 As String
Dim docname As String
Dim docaddpath As String
Dim fulldoc As String
Dim syllabifile As String
Dim syllabidoc As String
Dim syllabidocx As String
Dim syllabipdf As String
Dim syllabiloc As String
Dim ABETfile As String
Dim ABETOf As String
Dim ABETOdoc As String
Dim ABETOdocx As String
Dim ABETOpdf As String
Dim ABETOloc As String
Dim ABETQf As String
Dim ABETQdoc As String
Dim ABETQdocx As String
Dim ABETQpdf As String
Dim ABETQtemp As String
Dim ABETQinst As String
Dim ABETQloc As String
Dim sqlstr As String
Dim abatt As Integer

abatt = 0       

        'RunCommand acCmdRecordsGoToLast  'This causes the email automation code to fail
        'RunCommand acCmdRecordsGoToFirst
        While Me.CurrentRecord <= Me.Recordset.RecordCount

            WhereSem = "[Semester_ID]= " & CLng(Forms![MenMain3]![NavigationSubform].Form![Semester])
            WhereYear = "[Year_ID]= " & CLng(Forms![MenMain3]![NavigationSubform].Form![YearSelect])
            WhereFac = "[Fac_ID]= " & CLng(Forms![MenMain3]![NavigationSubform].Form![FacEmailID])

            'Close report in case it's open
            DoCmd.Close acReport, "ScheduleEmail", acSaveYes 

            'Open report
            DoCmd.OpenReport "ScheduleEmail", acViewReport, , WhereSem & " And " & WhereYear & " And " & WhereFac 

            docuser = Environ$("USERPROFILE")
            docaddpath = Left(Reports!ScheduleEmail![Semester], 2) & Reports!ScheduleEmail![SemesterYear] & "\"
            docpath1 = docuser & "\documents\DB\Docs\"
            docpath2 = docpath1 & docaddpath
            docname = Reports!ScheduleEmail![Emp_Last] & Reports!ScheduleEmail![Emp_First]
            fulldoc = docpath2 & docname & ".pdf"

            If Dir(docpath1, vbDirectory) = "" Then
                MkDir (docpath1)
            End If

            If Dir(docpath2, vbDirectory) = "" Then
                MkDir (docpath2)
            End If

            DoCmd.OutputTo acOutputReport, , acFormatPDF, fulldoc, False

            ' Create the Outlook session.
            Set objOutlook = CreateObject("Outlook.Application")

            ' Create the message.
            Set objOutlookMsg = objOutlook.CreateItem(0)


            With objOutlookMsg
                ' Add the To recipient(s) to the message.
                .To = Me.Email

                ' Set the Subject, Body, and Importance of the message.
                .Subject = Me.emailsubject
                .Body = Me.EmailText

                ' Add attachments to the message.
                If Not IsMissing(AttachmentPath) Then
                    .Attachments.Add (fulldoc)

                    'Send the Syllabi for the class
                    Set db = CurrentDb()

                    WSemq = "Semester_ID =" & CLng(Forms![MenMain3]![NavigationSubform].Form![Semester])

                    WYearq = "Year_ID =" & CLng(Forms![MenMain3]![NavigationSubform].Form![YearSelect])

                    WFacq = "Fac_ID =" & CLng(Forms![MenMain3]![NavigationSubform].Form![FacEmailID])

                    Set rs = db.OpenRecordset("Select * FROM RE_SchedCourse_EmailAttachment2_Q WHERE " & WSemq & " And " & WYearq & " And " & WFacq, dbOpenDynaset)

                    If rs.RecordCount <> 0 Then
                        rs.MoveLast
                        rs.MoveFirst
                    End If

                    Do While Not rs.EOF

                        If IsNull(rs!Fac_ID) Then
                            Exit Do
                        End If

                        syllabifile = rs!Prefix & rs!Prefix_Num & " Syllabus"
                        syllabiloc = "S:\Latest Syllabi\"
                        syllabidoc = syllabifile & ".doc"
                        syllabidocx = syllabifile & ".docx"
                        syllabipdf = syllabifile & ".pdf"

                        If FileExists(syllabiloc & syllabidoc) Then
                            .Attachments.Add (syllabiloc & syllabidoc)
                        ElseIf FileExists(syllabiloc & syllabidocx) Then
                            .Attachments.Add (syllabiloc & syllabidocx)
                        ElseIf FileExists(syllabiloc & syllabipdf) Then
                            .Attachments.Add (syllabiloc & syllabipdf)
                        End If

                        'Set the ABETfile names
                        ABETfile = rs!Prefix & " " & rs!Prefix_Num    '& " " & rs!Course_Name

                        'Set the ABET Outcomes files
                        ABETOf = ABETfile & " ABET Outcomes"
                        ABETOloc = "S:\ABET Outcomes\"
                        ABETOdoc = ABETOf & ".doc"
                        ABETOdocx = ABETOf & ".docx"
                        ABETOpdf = ABETOf & ".pdf"

                        'If there are ABET Outcomes send those
                        If FileExists(ABETOloc & ABETOdoc) Then
                            .Attachments.Add (ABETOloc & ABETOdoc)
                            abatt = abatt + 1
                        ElseIf FileExists(ABETOloc & ABETOdocx) Then
                            .Attachments.Add (ABETOloc & ABETOdocx)
                            abatt = abatt + 1
                        ElseIf FileExists(ABETOloc & ABETOpdf) Then
                            .Attachments.Add (ABETOloc & ABETOpdf)
                            abatt = abatt + 1
                        End If

                        'Set the ABET Quizzes files
                        ABETQf = ABETfile & " ABET Quizzes"
                        ABETQloc = "S:\ABET Quizzes\"
                        ABETQtemp = "ABET Data Fall TEMPLATE.xlsx"
                        ABETQinst = "ABET TESTS (instructions).docx"
                        ABETQdoc = ABETQf & ".doc"
                        ABETQdocx = ABETQf & ".docx"
                        ABETQpdf = ABETQf & ".pdf"

                        'If there are ABET Quizzes send those
                        If FileExists(ABETQloc & ABETQdoc) Then
                            .Attachments.Add (ABETQloc & ABETQdoc)
                            abatt = abatt + 1
                        ElseIf FileExists(ABETQloc & ABETQdocx) Then
                            .Attachments.Add (ABETQloc & ABETQdocx)
                            abatt = abatt + 1
                        ElseIf FileExists(ABETQloc & ABETQpdf) Then
                            .Attachments.Add (ABETQloc & ABETQpdf)
                            abatt = abatt + 1
                        End If

                        If rs.RecordCount <> 0 Then
                            rs.MoveNext
                        End If
                    Loop

                    'Attach extra ABET Quiz documents
                    If abatt >= 1 Then
                        Set objOutlookAttach = .Attachments.Add(ABETQloc & ABETQtemp)
                        Set objOutlookAttach = .Attachments.Add(ABETQloc & ABETQinst)
                        abatt = 0
                    End If

                    rs.Close

                    Set rs = Nothing

                End If

                ' Resolve each Recipient's name.
                For Each objOutlookRecip In .Recipients
                    objOutlookRecip.Resolve
                Next

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

            Set objOutlook = Nothing

            DoCmd.Close acReport, "ScheduleEmail", acSaveYes

            If Me.CurrentRecord <= Me.Recordset.RecordCount Then

                DoCmd.GoToRecord record:=acNext
            Else: DoCmd.GoToRecord record:=acFirst
            End If
        Wend

[EDIT]

Here's what the button code looks like now. Because I'm referencing a subform everything seems to be messed up with how the references are made:

Private Sub SchedEmailButton_Click()

Dim rst As DAO.Recordset

Set rst = Me.FacEmailingList2.Form.Recordset

Me.FacEmailingList2.SetFocus
RunCommand acCmdRecordsGoToLast
RunCommand acCmdRecordsGoToFirst

While Not rst.EOF 'CurentRecord <= RecordCount

    SchedEmail
    'RunCommand acCmdRecordsGoToNext
    DoCmd.GoToRecord record:=acNext

    If rst.EOF Then 'CurrentRecord <= Recordset.RecordCount Then

        DoCmd.GoToRecord record:=acNext
    Else: DoCmd.GoToRecord record:=acFirst
    End If
Wend

Here's the basic changes I've made to the email loop (I've made it it's own procedure, this is more for reference than anything):

Sub SchedEmail()

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFiltered As DAO.Recordset
Dim WhereSem As String
Dim WhereYear As String
Dim WhereFac As String
Dim WSemq As String
Dim WYearq As String
Dim WFacq As String
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objOutlookRecip As Object
Dim objOutlookAttach As Object
Dim docuser As String
Dim docpath1 As String
Dim docpath2 As String
Dim docname As String
Dim docaddpath As String
Dim fulldoc As String
Dim syllabifile As String
Dim syllabidoc As String
Dim syllabidocx As String
Dim syllabipdf As String
Dim syllabiloc As String
Dim ABETfile As String
Dim ABETOf As String
Dim ABETOdoc As String
Dim ABETOdocx As String
Dim ABETOpdf As String
Dim ABETOloc As String
Dim ABETQf As String
Dim ABETQdoc As String
Dim ABETQdocx As String
Dim ABETQpdf As String
Dim ABETQtemp As String
Dim ABETQinst As String
Dim ABETQloc As String
Dim sqlstr As String
Dim abatt As Integer

abatt = 0       

        'RunCommand acCmdRecordsGoToLast  'This causes the email automation code to fail
        'RunCommand acCmdRecordsGoToFirst
        While Me.CurrentRecord <= Me.Recordset.RecordCount

            WhereSem = "[Semester_ID]= " & CLng(Forms![MenMain3]![NavigationSubform].Form![Semester])
            WhereYear = "[Year_ID]= " & CLng(Forms![MenMain3]![NavigationSubform].Form![YearSelect])
            WhereFac = "[Fac_ID]= " & CLng(Forms![MenMain3]![NavigationSubform].Form![FacEmailID])

            'Close report in case it's open
            DoCmd.Close acReport, "ScheduleEmail", acSaveYes 

            'Open report
            DoCmd.OpenReport "ScheduleEmail", acViewReport, , WhereSem & " And " & WhereYear & " And " & WhereFac 

            docuser = Environ$("USERPROFILE")
            docaddpath = Left(Reports!ScheduleEmail![Semester], 2) & Reports!ScheduleEmail![SemesterYear] & "\"
            docpath1 = docuser & "\documents\DB\Docs\"
            docpath2 = docpath1 & docaddpath
            docname = Reports!ScheduleEmail![Emp_Last] & Reports!ScheduleEmail![Emp_First]
            fulldoc = docpath2 & docname & ".pdf"

            If Dir(docpath1, vbDirectory) = "" Then
                MkDir (docpath1)
            End If

            If Dir(docpath2, vbDirectory) = "" Then
                MkDir (docpath2)
            End If

            DoCmd.OutputTo acOutputReport, , acFormatPDF, fulldoc, False

            ' Create the Outlook session.
            Set objOutlook = CreateObject("Outlook.Application")

            ' Create the message.
            Set objOutlookMsg = objOutlook.CreateItem(0)


            With objOutlookMsg
                ' Add the To recipient(s) to the message.
                .To = Me.Email

                ' Set the Subject, Body, and Importance of the message.
                .Subject = Me.emailsubject
                .Body = Me.EmailText

                ' Add attachments to the message.
                If Not IsMissing(AttachmentPath) Then
                    .Attachments.Add (fulldoc)

                    'Send the Syllabi for the class
                    Set db = CurrentDb()

                    WSemq = "Semester_ID =" & CLng(Forms![MenMain3]![NavigationSubform].Form![Semester])

                    WYearq = "Year_ID =" & CLng(Forms![MenMain3]![NavigationSubform].Form![YearSelect])

                    WFacq = "Fac_ID =" & CLng(Forms![MenMain3]![NavigationSubform].Form![FacEmailID])

                    Set rs = db.OpenRecordset("Select * FROM RE_SchedCourse_EmailAttachment2_Q WHERE " & WSemq & " And " & WYearq & " And " & WFacq, dbOpenDynaset)

                    If rs.RecordCount <> 0 Then
                        rs.MoveLast
                        rs.MoveFirst
                    End If

                    Do While Not rs.EOF

                        If IsNull(rs!Fac_ID) Then
                            Exit Do
                        End If

                        syllabifile = rs!Prefix & rs!Prefix_Num & " Syllabus"
                        syllabiloc = "S:\Latest Syllabi\"
                        syllabidoc = syllabifile & ".doc"
                        syllabidocx = syllabifile & ".docx"
                        syllabipdf = syllabifile & ".pdf"

                        If FileExists(syllabiloc & syllabidoc) Then
                            .Attachments.Add (syllabiloc & syllabidoc)
                        ElseIf FileExists(syllabiloc & syllabidocx) Then
                            .Attachments.Add (syllabiloc & syllabidocx)
                        ElseIf FileExists(syllabiloc & syllabipdf) Then
                            .Attachments.Add (syllabiloc & syllabipdf)
                        End If

                        'Set the ABETfile names
                        ABETfile = rs!Prefix & " " & rs!Prefix_Num    '& " " & rs!Course_Name

                        'Set the ABET Outcomes files
                        ABETOf = ABETfile & " ABET Outcomes"
                        ABETOloc = "S:\ABET Outcomes\"
                        ABETOdoc = ABETOf & ".doc"
                        ABETOdocx = ABETOf & ".docx"
                        ABETOpdf = ABETOf & ".pdf"

                        'If there are ABET Outcomes send those
                        If FileExists(ABETOloc & ABETOdoc) Then
                            .Attachments.Add (ABETOloc & ABETOdoc)
                            abatt = abatt + 1
                        ElseIf FileExists(ABETOloc & ABETOdocx) Then
                            .Attachments.Add (ABETOloc & ABETOdocx)
                            abatt = abatt + 1
                        ElseIf FileExists(ABETOloc & ABETOpdf) Then
                            .Attachments.Add (ABETOloc & ABETOpdf)
                            abatt = abatt + 1
                        End If

                        'Set the ABET Quizzes files
                        ABETQf = ABETfile & " ABET Quizzes"
                        ABETQloc = "S:\ABET Quizzes\"
                        ABETQtemp = "ABET Data Fall TEMPLATE.xlsx"
                        ABETQinst = "ABET TESTS (instructions).docx"
                        ABETQdoc = ABETQf & ".doc"
                        ABETQdocx = ABETQf & ".docx"
                        ABETQpdf = ABETQf & ".pdf"

                        'If there are ABET Quizzes send those
                        If FileExists(ABETQloc & ABETQdoc) Then
                            .Attachments.Add (ABETQloc & ABETQdoc)
                            abatt = abatt + 1
                        ElseIf FileExists(ABETQloc & ABETQdocx) Then
                            .Attachments.Add (ABETQloc & ABETQdocx)
                            abatt = abatt + 1
                        ElseIf FileExists(ABETQloc & ABETQpdf) Then
                            .Attachments.Add (ABETQloc & ABETQpdf)
                            abatt = abatt + 1
                        End If

                        If rs.RecordCount <> 0 Then
                            rs.MoveNext
                        End If
                    Loop

                    'Attach extra ABET Quiz documents
                    If abatt >= 1 Then
                        Set objOutlookAttach = .Attachments.Add(ABETQloc & ABETQtemp)
                        Set objOutlookAttach = .Attachments.Add(ABETQloc & ABETQinst)
                        abatt = 0
                    End If

                    rs.Close

                    Set rs = Nothing

                End If

                ' Resolve each Recipient's name.
                For Each objOutlookRecip In .Recipients
                    objOutlookRecip.Resolve
                Next

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

            Set objOutlook = Nothing

            DoCmd.Close acReport, "ScheduleEmail", acSaveYes

            If Me.CurrentRecord <= Me.Recordset.RecordCount Then

                DoCmd.GoToRecord record:=acNext
            Else: DoCmd.GoToRecord record:=acFirst
            End If

what's your interest


forum_ban8_5d8c5fd7cf6f7.gif