Popular Categories

MS Access While Loop Skips first record

Course Queries Syllabus Queries 2 years ago

Write a Review
Report

5 Star Rating 1 Rating

Previous Next

Posted on 16 Aug 2022, this text provides information on Syllabus Queries related to Course Queries. Please note that while accuracy is prioritized, the data presented might not be entirely correct or up-to-date. This information is offered for general knowledge and informational purposes only, and should not be considered as a substitute for professional advice.

Take Quiz To Earn Credits!

Turn Your Knowledge into Earnings.

Answers (2)

Post Answer

manpreet Best Answer 2 years 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

0 views

0 shares

manpreet 2 years ago

I finally got this to work!

Wayne's suggestion of moving the code from the sub form "Current" event to the buttons "Click" event was very helpful and got me on the right path.

I had a bit of an issue with how to get the loop to go to the next record, but this is what I ended up with after searching a bit more:

Private Sub SchedEmailButton_Click()

Dim rst As Object 'DAO.Recordset    <-- For some reason unknown to me the code didn't like declaring as a "DAO.Recordset"

Set rst = Me.FacEmailingList2.Form.Recordset

With rst
            .MoveFirst
            Do While Not .EOF
                SchedEmail
                .MoveNext
            Loop
        End With
        Set rst = Nothing

These didn't work to move to the next record (I don't know why):

RunCommand acCmdRecordsGoToNext
DoCmd.GoToRecord record:=acNext
DoCmd.GoToRecord , , acNext

0 views 0 shares

No matter what stage you're at in your education or career, TuteeHub will help you reach the next level that you're aiming for. Simply,Choose a subject/topic and get started in self-paced practice sessions to improve your knowledge and scores.

Explore Other Libraries

Blogs Tutorials Question Bank Feeds Careernews

Popular Categories

MS Access While Loop Skips first record

Take Quiz To Earn Credits!

Answers (2)

manpreet Best Answer 2 years ago

manpreet 2 years ago

when will be released admit card of IBPS Clerk Prelims 2018?

What is good preparation material for the IBPS Bank PO Exam?

Sir, When the admit card will be released for the post of Junior Executive (IT/CS)?

UPPRPB Recruitment – 3638 Jail Warder Vacancy – Last Date 28 December 2018

Indian Navy recruitment notification for 275 posts of Trade Apprentice.

What is the full form of NABARD ?

How to refresh app upon shaking the device?

What are the govt exams after BCA?

TYPO3 v8. Override function in Core class

Why do people in India give so much importance to Government jobs?

<div>zkskKsk</div>

<span style="font-size: 1em;">Qwerty 4</span>

<div>What are the key differences between AMOLED and LCD displays in smartphones?</div>

<div>What are the key challenges in Mobile App Development for Cross-Platform Solutions?</div>

who is the smallest man in the world

Explore Other Libraries

Tags

Important Course Queries Links

Join Our Community Today