MS Access While Loop跳过第一条记录

时间：2014-12-29 21:13:06

标签： access-vba

我有一个拆分的多用户MS Access（2013年ACCDE文件）数据库，用于通过电子邮件将课程表和教学大纲发送给教授。当用户准备发送电子邮件时，最终用户按下表单上的按钮，然后数据库具有在子表单中的过滤数据表中循环每个条目（大约70）的代码。通常，添加附件和发送电子邮件的代码有效...但是，如下面的代码设置如何，电子邮件列表中的最后一个人通过电子邮件发送两次......他们都是数据库发送的第一个和最后一个人发送电子邮件给...

我在下面列出了我的相关代码。一如既往，我非常感谢您提供的任何帮助。

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

或者，我也尝试了这个按钮，这时只跳过第一条记录（因此我的帖子标题）：

Private Sub SchedEmailButton_Click()

    Dim rst As DAO.Recordset

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

这是循环通过电子邮件收件人列表的代码，被剥离（编辑）到真正重要的因为它的长度：

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

[编辑]这是完整的代码（以防万一）：

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

[编辑]

这是按钮代码现在的样子。因为我引用了一个子表单，所以看起来一切都搞砸了引用的方式：

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

以下是我对电子邮件循环所做的基本更改（我已经将其设置为自己的程序，这比任何内容都更适合参考）：

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

1 个答案:

答案 0 :(得分：0)

我终于让它起作用了！

Wayne关于从子表单中移动代码的建议＆＃34; Current＆＃34;事件到按钮＆＃34;点击＆＃34;活动非常有帮助，让我走上了正确的道路。

关于如何让循环转到下一条记录，我遇到了一些问题，但这是我在搜索之后最终得到的结果：

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

这些没有工作转移到下一条记录（我不知道为什么）：

RunCommand acCmdRecordsGoToNext
DoCmd.GoToRecord record:=acNext
DoCmd.GoToRecord , , acNext
相关问题
最新问题