Error 3251. Current recordset does not support updating. HELP! This app (I think) worked in Access 2000

My current references are
Visual Basic for Applications
Microsoft Access 11.0 Object Library
Microsoft Visual Basic for Applications extensibility 5.3
OLE Automation
"utility"
Microsoft DAO 3.6 Object Library
Microsoft Activex Data Objects 2.5 Library


It crashes around here. It does go through this loop many times but then crashes before hitting the line following the loop.

Set rsMySet = dbCommand.Execute
     
            If rsMySet.EOF Then
                MsgBox "No Mailing List To Produce", vbExclamation, "NO MAILING LIST"
            Else
   
                Do While Not rsMySet.EOF
                    rstMailingLabels.AddNew
                    rstMailingLabels!studentid = rsMySet!studentid
                    rstMailingLabels!AcademicProgram = rsMySet!AcademicProgram
                    rstMailingLabels!Term = rsMySet!Term
                    rstMailingLabels!PersonID = rsMySet!PersonID
                    rstMailingLabels!FullName = rsMySet!FullName
                    rstMailingLabels!LastName = rsMySet!LastName
                    rstMailingLabels!FirstName = rsMySet!FirstName
                    rstMailingLabels!Address1 = rsMySet!Address1
                    If Not rsMySet!Address2 = "" Then
                    rstMailingLabels!Address2 = rsMySet!Address2
                    Else
                     rstMailingLabels!Address2 = "."
                    End If
                    If Not rsMySet!Address3 = "" Then
                    rstMailingLabels!Address3 = rsMySet!Address3
                    Else
                    rsMySet!Address3 = "."
                    End If
                    If Not rsMySet!Address4 = "" Then
                    rstMailingLabels!Address4 = rsMySet!Address4
                    Else
                    rsMySet!Address4 = "."
                    End If
                   
                    rstMailingLabels!City = rsMySet!City
                    rstMailingLabels!Province = rsMySet!Province
                    rstMailingLabels!Country = rsMySet!Country
                    rstMailingLabels!PostalCode = rsMySet!PostalCode
                    rstMailingLabels.Update
                    rsMySet.MoveNext
                Loop
------------------------------------------------------------------------------------
This is the complete code for the Subroutuine        



Private Sub cmdProduceMailingList_Click()
'Created by -
'YOU MUST INCLUDE THE REFERENCE TO 'Microsoft ActiveX Data Objects Library 2.1'! -> Access 97 users
'YOU MUST INCLUDE THE REFERENCE TO 'Microsoft ActiveX Data Objects Library 2.5'! -> Access 2000 users


Dim wsCurrent As Workspace
Dim dbCurrent As Database
Dim TransactionErrorFlag As Integer
Dim dbConnection As ADODB.Connection
Dim dbCommand As ADODB.Command
Dim rsMySet As ADODB.Recordset
Dim rstMailingLabels As Recordset
Dim qdMailingLabels As QueryDef
Dim rstMailingLabels2 As Recordset
Dim qdMailingLabels2 As QueryDef
Dim rstMailingLabelstoExcel As Recordset
Dim qdMailingLabelstoExcel As QueryDef
Dim rstSelectedSemesters As Recordset
Dim qdSelectedSemesters As QueryDef

'RechelA Dec 2004
Dim rstMailedOutLabels As Recordset
Dim qdMailedOutLabels As QueryDef

Dim Term As String
'Set up minimal error handling routine.
On Error GoTo ErrRtn
TransactionErrorFlag = 0

Set wsCurrent = DBEngine.Workspaces(0)
Set dbCurrent = CurrentDb()

If IsNull(Me.txtStartDate) Or IsNull(Me.txtEndDate) Or IsNull(Me.cboTerm) Or IsNull(Me.cboYear) Then
    MsgBox "You Must Enter a Start Date, a End Date, a Term, an Academic Year and a Group of Students That You Want to Produce a Mailing List For", vbInformation, "INVALID ENTRY"
   
    Else
    'Retrieve the selected Semesters from the lstSelectedSemesters list box
    Set qdSelectedSemesters = dbCurrent.QueryDefs("qrySelectedSemesters")
    Set rstSelectedSemesters = qdSelectedSemesters.OpenRecordset(dbOpenDynaset)
   
    If rstSelectedSemesters.EOF Then
        MsgBox "You Must Select the Semester or Semesters That You Would Like to Produce the Mailing List for", vbInformation, "NO SEMESTERS SELECTED"
    Else
        DoCmd.Hourglass (True)
        Set dbConnection = New ADODB.Connection
        'To find the following ActiveConnection string:
            'Right-click on your desktop and select 'New' -> 'Microsoft Data Link'.
            'Double-click on the new Data Link icon and select 'Provider' -> 'Microsoft OLE DB Provider for SQL Server' -> 'Next'.
            'Enter the appropriate settings and click 'OK'.
            'Send the new Data Link icon to notepad and copy - paste the OLE DB initstring.
       
        dbConnection.Open "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=v23"
        dbConnection.DefaultDatabase = "People"
       
        If dbConnection.State = adStateOpen Then
   
            TransactionErrorFlag = 1
            'Clear the table 'tblMailingListTemp' which holds the data before the appropriate semesters are filtered out
            dbCurrent.Execute "Delete * from tblMailingListTemp", dbFailOnError 'Delete TempTable
            'Clear the table 'tblMailingListTemp2' which holds the data after the appropriate semesters are filtered out
            dbCurrent.Execute "Delete * from tblMailingListTemp2", dbFailOnError 'Delete TempTable
       
            Set qdMailingLabels = dbCurrent.QueryDefs("qryMailingLabels1")
            Set rstMailingLabels = qdMailingLabels.OpenRecordset(dbOpenDynaset)
                               
            'Add the data from the stored procedure 'USP_ParkingStudentMailingList' on the v23 server, 'People' database.
            'to 'tblMailingListTemp'
            Set dbCommand = New ADODB.Command
            Set dbCommand.ActiveConnection = dbConnection
            dbCommand.CommandTimeout = 999
           
           'Code Edited by TedR June 2 2004 - New Stored Procedure From Datawarehouse
            'dbCommand.CommandText = "USP_ParkingStudentMailingSept"
            dbCommand.CommandText = "USP_StudentParkingReminder"
            dbCommand.CommandType = adCmdStoredProc
            dbCommand.Parameters.Refresh
           
            dbCommand(1) = Me.txtStartDate
            dbCommand(2) = Me.txtEndDate
           
            ' build the string to pass in the appropriate term which includes
            ' 1 - Century (2000 - 2100)
            ' Middle two digits of string to represent the year
            ' and the last digit of the string represents the term
            ' Term 0 is Summer: July, term 1 is Fall: Aug - Dec, and term 2 is Winter: Jan-Apr
            ' eg. 1001 represent the Fall term of the year 2000 (Aug - Dec)
           
            Term = "1" & Right(Me.cboYear, 2) & Me.cboTerm
            dbCommand(3) = Term
   


            Set rsMySet = dbCommand.Execute
     
            If rsMySet.EOF Then
                MsgBox "No Mailing List To Produce", vbExclamation, "NO MAILING LIST"
            Else
   
                Do While Not rsMySet.EOF
                    rstMailingLabels.AddNew
                    rstMailingLabels!studentid = rsMySet!studentid
                    rstMailingLabels!AcademicProgram = rsMySet!AcademicProgram
                    rstMailingLabels!Term = rsMySet!Term
                    rstMailingLabels!PersonID = rsMySet!PersonID
                    rstMailingLabels!FullName = rsMySet!FullName
                    rstMailingLabels!LastName = rsMySet!LastName
                    rstMailingLabels!FirstName = rsMySet!FirstName
                    rstMailingLabels!Address1 = rsMySet!Address1
                    If Not rsMySet!Address2 = "" Then
                    rstMailingLabels!Address2 = rsMySet!Address2
                    Else
                     rstMailingLabels!Address2 = "."
                    End If
                    If Not rsMySet!Address3 = "" Then
                    rstMailingLabels!Address3 = rsMySet!Address3
                    Else
                    rsMySet!Address3 = "."
                    End If
                    If Not rsMySet!Address4 = "" Then
                    rstMailingLabels!Address4 = rsMySet!Address4
                    Else
                    rsMySet!Address4 = "."
                    End If
                   
                    rstMailingLabels!City = rsMySet!City
                    rstMailingLabels!Province = rsMySet!Province
                    rstMailingLabels!Country = rsMySet!Country
                    rstMailingLabels!PostalCode = rsMySet!PostalCode
                    rstMailingLabels.Update
                    rsMySet.MoveNext
                Loop
       
                Set qdMailingLabels2 = dbCurrent.QueryDefs("qryMailingLabels2")
                Set rstMailingLabels2 = qdMailingLabels2.OpenRecordset(dbOpenDynaset)
         
                'RechelA Dec 2004
                Set qdMailedOutLabels = dbCurrent.QueryDefs("qryMailedOutLabels")
                Set rstMailedOutLabels = qdMailedOutLabels.OpenRecordset(dbOpenDynaset)
         
                Set qdMailingLabelstoExcel = dbCurrent.QueryDefs("qryMailingLabels")
                 
                Do While Not rstSelectedSemesters.EOF
                    'Pass in each semester one at a time into the qryMailingLabels in order to filter out unselected semesters
                     qdMailingLabelstoExcel.Parameters("Semester") = rstSelectedSemesters!Semester
                     Set rstMailingLabelstoExcel = qdMailingLabelstoExcel.OpenRecordset(dbOpenDynaset)
   
                    'Add the appropriate records from ' tblMailingListTemp' to 'tblMailingListTemp2' for the selected semesters
                    Do While Not rstMailingLabelstoExcel.EOF
                        rstMailingLabels2.AddNew
                        'rstMailingLabels2!studentid = rstMailingLabelstoExcel!studentid  Taken out July 04/2000 due to foip
                        rstMailingLabels2!LastName = rstMailingLabelstoExcel!LastName
                        rstMailingLabels2!FirstName = rstMailingLabelstoExcel!FirstName
                        rstMailingLabels2!Address1 = rstMailingLabelstoExcel!Address1
                        rstMailingLabels2!City = rstMailingLabelstoExcel!City
                        rstMailingLabels2!Province = rstMailingLabelstoExcel!Province
                        rstMailingLabels2!PostalCode = rstMailingLabelstoExcel!PostalCode
                        rstMailingLabels2!Country = rstMailingLabelstoExcel!Country
                        rstMailingLabels2.Update
                        'Add records to tblMailedOutLabels
                        'RechelA Dec 2004
                        rstMailedOutLabels.AddNew
                        rstMailedOutLabels!studentid = rstMailingLabelstoExcel!studentid
                        rstMailedOutLabels!LastName = rstMailingLabelstoExcel!LastName
                        rstMailedOutLabels!FirstName = rstMailingLabelstoExcel!FirstName
                        rstMailedOutLabels!Address1 = rstMailingLabelstoExcel!Address1
                        rstMailedOutLabels!City = rstMailingLabelstoExcel!City
                        rstMailedOutLabels!Province = rstMailingLabelstoExcel!Province
                        rstMailedOutLabels!PostalCode = rstMailingLabelstoExcel!PostalCode
                        rstMailedOutLabels!Country = rstMailingLabelstoExcel!Country
                        rstMailedOutLabels!DatePrinted = Now()
                        rstMailedOutLabels.Update
                        rstMailingLabelstoExcel.MoveNext
                    Loop
                   
                    ' If the Semester number one is selected
                    ' Must also take all records that end in an A in order to include
                    ' EMTA records which do not have a semester number
                    If rstSelectedSemesters!Semester = 1 Then
                        qdMailingLabelstoExcel.Parameters("Semester") = "A"
                        Set rstMailingLabelstoExcel = qdMailingLabelstoExcel.OpenRecordset(dbOpenDynaset)
       
                        Do While Not rstMailingLabelstoExcel.EOF
                            rstMailingLabels2.AddNew
                           ' rstMailingLabels2!studentid = rstMailingLabelstoExcel!studentid  Taken out July 04/2000 due to foip
                            rstMailingLabels2!LastName = rstMailingLabelstoExcel!LastName
                            rstMailingLabels2!FirstName = rstMailingLabelstoExcel!FirstName
                            rstMailingLabels2!Address1 = rstMailingLabelstoExcel!Address1
                            rstMailingLabels2!City = rstMailingLabelstoExcel!City
                            rstMailingLabels2!Province = rstMailingLabelstoExcel!Province
                            rstMailingLabels2!PostalCode = rstMailingLabelstoExcel!PostalCode
                            rstMailingLabels2!Country = rstMailingLabelstoExcel!Country
                            rstMailingLabels2.Update
                            'Add records to tblMailedOutLabels
                            'RechelA Dec 2004
                            rstMailedOutLabels.AddNew
                            rstMailedOutLabels!studentid = rstMailingLabelstoExcel!studentid
                            rstMailedOutLabels!LastName = rstMailingLabelstoExcel!LastName
                            rstMailedOutLabels!FirstName = rstMailingLabelstoExcel!FirstName
                            rstMailedOutLabels!Address1 = rstMailingLabelstoExcel!Address1
                            rstMailedOutLabels!City = rstMailingLabelstoExcel!City
                            rstMailedOutLabels!Province = rstMailingLabelstoExcel!Province
                            rstMailedOutLabels!PostalCode = rstMailingLabelstoExcel!PostalCode
                            rstMailedOutLabels!Country = rstMailingLabelstoExcel!Country
                            rstMailedOutLabels!DatePrinted = Now()
                            rstMailedOutLabels.Update
                            rstMailingLabelstoExcel.MoveNext
                        Loop
                    End If
                   
                    rstSelectedSemesters.MoveNext
                Loop
         
                If DCount("*", "qryMailingLabels2") > 0 Then
                    DoCmd.RunMacro "LabelsToExport"
                    DoCmd.Hourglass (False)
                    MsgBox "The Mailing List Has Been Produced", vbInformation, "MAILING LIST COMPLETED"
                Else
                    DoCmd.Hourglass (False)
                    MsgBox "No Mailing List To Produce", vbInformation, "NO MAILING LIST"
                End If
               
                'Clear the table 'tblMailingListTemp' which holds the data before the appropriate semesters are filtered out
                dbCurrent.Execute "Delete * from tblMailingListTemp", dbFailOnError 'Delete TempTable
                'Clear the table 'tblMailingListTemp2' which holds the data after the appropriate semesters are filtered out
                dbCurrent.Execute "Delete * from tblMailingListTemp2", dbFailOnError 'Delete TempTable
       
                'Delete the tblSelectedSemesterTemp table which holds the selected semesters
                dbCurrent.Execute "Delete * from tblSelectedSemesterTemp", dbFailOnError
                Me.lstSelectedSemesters.Requery
                Me.lstSemesters.Requery
                rstMailingLabels2.Close
                rstMailingLabelstoExcel.Close
               
                'RechelA Dec 2004
                rstMailedOutLabels.Close
               
            End If
           
            rstMailingLabels.Close
            rsMySet.Close
       
            TransactionErrorFlag = 0
            Set rsMySet = Nothing
        End If
       
    End If
   
    rstSelectedSemesters.Close
End If
DoCmd.Hourglass (False)

ExitRtn:
    Exit Sub
ErrRtn:
    Select Case TransactionErrorFlag
        Case 0: MsgBox "Error " & Err.Number & " occured. " & Err.Description & ". Contact Customer Support for assistance."
                 DoCmd.Hourglass (False)
        Case 1: MsgBox "Error Performing Adjust: " & "Error " & Err.Number & " occured. " & Err.Description & ". Contact Customer Support for assistance." & " Update rollbacks."
                 DoCmd.Hourglass (False)
    End Select
    Resume ExitRtn
End Sub
peterdidowAsked:
Who is Participating?
 
harfangConnect With a Mentor Commented:
Hello,

The problem is: "It crashes around here." It would be best to have the exact line, as well as the error message.

To obtain that, either remore (comment out) the "On Error Goto" statement at the start -- but that can be a problem with transactions -- or from VB choose "Tools / Options", [General] tab, check "Break on all errors". You should now get the more useful "[Debug]/[End]" error, at which point you will click Debug. The line highlighted in yellow is the offending line. You can try to "re-run" it by using the triangular "advance" button or [F5].

The good thing is that you can use the immediate pane to examine all variables, field contents, object  properties. You can even change these values, and move the yellow highlight to another line to resume execution.

Once you have pinpointed the location and the problem, you probably won't need our help ;)

Happy debugging!
(°v°)
0
 
peterdidowAuthor Commented:
Thanks - I was able to track it down after all and it was pretty simple.
0
 
harfangCommented:
Glad to hear that ;) Good luck now!
(°v°)
0
All Courses

From novice to tech pro — start learning today.