Need Automation & DataGrid Error Work Around

[PennyR]

On my form exists a listbox of assessments, a listbox of categories, and a datagrid of a student numbers, student names, and categor columns for the varying number of categories within an assessment. So to the user the datagrid looks like a spreadsheet of their students. The user clicks into a category column and depresses a number 1-4 for a score. The form then updates the tables in SQL Server 2000 and returns focus back to where the last score updated.

This used to work but for some reason that I cannot figure out doesn't anymore.

Upon update to the database the first error says:

-2147417848-Automation error
The object invoked has disconnected from its clients.

The second error says:
6145
DataGrid
Invalid column index


Now, another funny thing happens. If I add a break in the code and simply click the 'Run Sub' command again, no error is thrown. I can also add a msgbox that says "Updated" just before the End Sub and that too eliminates the error but for a user to have to click the OK button after every score post is inconvenient.


Documentation says it could be a whole host of problems many layers deep but I need this fixed right away. I was thinking that if I could just have a delay or be able to have the msgbox close automatically, that would get us by as this app will only be used the rest of the school year and then retired.

Can anyone please help??


************************************************************
CODE on the SUBFORM

************************************************************


Option Compare Database
Option Explicit

Private Const CAT_COUNT_SQL As String = "SELECT Count(*) FROM Assessment.dbo.tblAACategory WHERE UnitIDNbr = "
Private Const MASTER_SQL As String = "SELECT StudentNumber FROM IC_Export.dbo.tblCourseLoad " _
& " WHERE (CourseNumber = 'xxx') AND (SectionNumber = 'yyy')"

Private Const BASE_SQL As String = "SELECT StudentNumber, MAX(Grade) AS Grade, LastFirstMI AS Student, UnitIDCode, UnitIDNbr"
Private Const FROM_SQL As String = " FROM Assessment.dbo.vBHS_StudentCategoryScoreList"
Private Const WHERE_SQL As String = " WHERE UnitIDNbr = "
Private Const ORDER_SQL As String = " ORDER BY LastFirstMI, StudentNumber"
Private Const GROUP_SQL As String = " GROUP BY StudentNumber, Grade, LastFirstMI, UnitIDCode, UnitIDNbr"


Dim rsCatCount As New ADODB.Recordset
Dim rsMasterList As New ADODB.Recordset
Dim rsScore As New ADODB.Recordset

'___________________________________________________________
Private Sub dgdScore_KeyPress(KeyAscii As Integer)
Dim isUpdate As Boolean
Dim intCol As Integer
Dim lngMasterID As Long
Dim thisKey As String
Dim objError As ADODB.Error

On Error GoTo Err
isUpdate = False
thisKey = Chr(KeyAscii)
If dgdScore.Col >= 5 Then
Select Case KeyAscii
Case Asc("1") To Asc("4")
Call UpdateScore(Chr(KeyAscii))
isUpdate = True
Case Asc(vbBack), Asc("0"), Asc(" ")
Call UpdateScore(0)
isUpdate = True
Case Else
' ignore it
End Select
End If

If isUpdate Then
intCol = Me.dgdScore.Col
lngMasterID = Me.dgdScore.Columns(0).Value
Call BuildSQL
rsScore.Find ("StudentNumber = " & lngMasterID)
Me.dgdScore.Col = intCol
Me.dgdScore.SetFocus
End If
Exit Sub
Err:
If Err.Number = 3021 Then
Resume Next
Else
MsgBox (Err.Number & vbCrLf & Err.Source & vbCrLf & Err.Description)
For Each objError In Me.Application.CurrentProject.Connection.Errors
MsgBox "Error: " & objError.Description
Next
End If
End Sub
'___________________________________________________________

' this gets the students and the number of category columns needed for the assessment AND IT WORKS
Public Sub BuildSQL()
Dim intCatCount As Integer
Dim intIndex As Integer
Dim strCatCountSQL As String
Dim strMasterSQL As String
Dim strMasterList As String
Dim strSQL As String
On Error GoTo ErrHandler
If (Me.lstUnitName > 0) And (Forms!frmMainMenu.fraTerm.Value = 1 Or Forms!frmMainMenu.fraTerm.Value = 2) _
And (Me.txtCourseCode <> "" And Me.txtSecNbr <> "") Then

' find the count of categories and build the sql
strCatCountSQL = CAT_COUNT_SQL & Me.lstUnitName.Column(2)

rsCatCount.Open strCatCountSQL, Application.CurrentProject.Connection, adOpenDynamic, adLockReadOnly
If rsCatCount.RecordCount > 0 Then
rsCatCount.MoveFirst
intCatCount = rsCatCount.Fields(0).Value
End If
rsCatCount.Close

' build the list of studentnumbers
strMasterSQL = MASTER_SQL
strMasterSQL = Replace(strMasterSQL, "xxx", Me.txtCourseCode)
strMasterSQL = Replace(strMasterSQL, "yyy", Me.txtSecNbr)
rsMasterList.Open strMasterSQL, Application.CurrentProject.Connection, adOpenDynamic, adLockReadOnly, adCmdText
If rsMasterList.RecordCount > 0 Then
strMasterList = ""
rsMasterList.MoveFirst
Do While Not rsMasterList.EOF
strMasterList = strMasterList & rsMasterList.Fields("StudentNumber").Value & ", "
rsMasterList.MoveNext
Loop
strMasterList = Mid(strMasterList, 1, Len(strMasterList) - 2)
Else
strMasterList = "-1"
End If
rsMasterList.Close

strSQL = BASE_SQL
For intIndex = 1 To intCatCount
strSQL = strSQL & ", CAST(MAX(CASE WHEN CatNbr = " _
& intIndex _
& " THEN Score ELSE NULL END) AS INT) AS Cat" _
& intIndex
Next
strSQL = strSQL & FROM_SQL _
& WHERE_SQL & Me.lstUnitName.Column(2) & " AND StudentNumber IN (" & strMasterList & ") " _
& GROUP_SQL & ORDER_SQL
Else
strSQL = BASE_SQL & FROM_SQL & WHERE_SQL & "-1" & GROUP_SQL
End If

If rsScore.State <> adStateClosed Then
rsScore.Close
End If
rsScore.Open strSQL, Me.Application.CurrentProject.Connection, adOpenStatic, adLockReadOnly
Set Me.dgdScore.DataSource = rsScore
Me.lblStudentCt.Caption = "# Students: " & rsScore.RecordCount
Me.dgdScore.Columns(0).Alignment = dbgCenter
For intIndex = 0 To Me.dgdScore.Columns.Count - 1
Select Case intIndex
Case 0
Me.dgdScore.Columns(intIndex).Alignment = dbgCenter
Me.dgdScore.Columns(intIndex).Width = 1000
Case Is > 4
Me.dgdScore.Columns(intIndex).Alignment = dbgCenter
Me.dgdScore.Columns(intIndex).Width = 600
Case 1, 3, 4
Me.dgdScore.Columns(intIndex).Visible = False
Case Else
Me.dgdScore.Columns(intIndex).Alignment = dbgLeft
Me.dgdScore.Columns(intIndex).Width = 2000
End Select
Next
ExitSub:
' MsgBox "No assesments exists for this content area.", vbInformation, "Error"
Exit Sub
ErrHandler:
If Err.Number = -2147217900 Or Err.Number = 57097 Or Err.Number = 3704 Then
' Resume Next
Else
MsgBox (Err.Number & "-" & Err.Description)
GoTo ExitSub
End If
End Sub
'___________________________________________________________

Private Sub UpdateScore(ByVal intNewScore As Integer)
Dim rsStudent As New ADODB.Recordset
Dim strSQL As String

' build the SQL string
strSQL = "SELECT * FROM Assessment.dbo.tblAAScore "
strSQL = strSQL & " WHERE UnitIDNbr = " & txtUnitIDNbr _
& " AND CatNbr = " & Me.dgdScore.Col - 4 _
& " AND StudentNumber = " & Me.dgdScore.Columns(0).Value


' open the recordset
rsStudent.Open strSQL, Application.CurrentProject.Connection, adOpenDynamic, adLockPessimistic

' manipulate the record
If intNewScore = 0 Then
' this is a delete
If rsStudent.RecordCount > 0 Then
If rsStudent.Fields("WasReplaced").Value = False Then
rsStudent.Delete
Else
MsgBox "This Assessment has been replaced. You must delete the replacement before you can delete this score.", vbInformation, "Delete Not Allowed"
End If
End If
Else
If rsStudent.RecordCount = 0 And intNewScore > 0 Then
' this is an add, so make sure to fill in the unique index
rsStudent.AddNew
rsStudent.Fields("UnitIDNbr").Value = Me.txtUnitIDNbr
rsStudent.Fields("CatNbr").Value = Me.dgdScore.Col - 4
rsStudent.Fields("StudentNumber").Value = Me.dgdScore.Columns(0).Value
rsStudent.Fields("WasReplaced").Value = 0
rsStudent.Fields("SchYear").Value = Forms!frmMainMenu.txtCurrentYr
rsStudent.Fields("Grade").Value = Me.dgdScore.Columns(1).Value
Select Case Forms!frmMainMenu.fraTerm.Value
Case Is = 1, 2
rsStudent.Fields("Term").Value = Forms!frmMainMenu.fraTerm.Value
Case Else
rsStudent.Fields("Term").Value = 99
End Select
rsStudent.Fields("SecNbr").Value = Me.txtSecNbr
rsStudent.Fields("CourseCode").Value = Me.txtCourseCode
rsStudent.Fields("CourseTitle").Value = Me.txtCourseTitle
rsStudent.Fields("TeacherCode").Value = Me.txtTeacherCode
rsStudent.Fields("CACode").Value = Me.txtClassCACode
'added here
rsStudent.Fields("ByWhom").Value = Forms!frmMainMenu.txtLoginUserCode
Else
If rsStudent.Fields("UnitIDNbr") = "" _
Or rsStudent.Fields("CatNbr") = "" _
Or rsStudent.Fields("SecNbr") = "" _
Or rsStudent.Fields("CourseCode") = "" _
Or rsStudent.Fields("CourseTitle") = "" _
Or rsStudent.Fields("TeacherCode") = "" _
Or rsStudent.Fields("CACode") = "" Then

MsgBox "There is missing data. The following fields must have data: StudentNumber, " _
& "Grade, SchYear,Course Title, Course Code, Section Number, Teacher Code, Term, Content Area Code " _
& " Unit ID Number, Category Number, Was Replaced Code."

Else
End If
End If

'update the remainder of the header fields
If rsStudent.Fields("WasReplaced").Value <> 0 Then
MsgBox "You can't change a score once the Assessment has been replaced. First delete the replacement if this score must be changed.", vbInformation, "Change Not Allowed"
Else
rsStudent.Fields("Score").Value = intNewScore
End If

End If

' update the database
rsStudent.Update

' close the recordset
If rsStudent.State <> adStateClosed Then
rsStudent.Close
End If
Set rsStudent = Nothing
'IF I PUT MSGBOX "UPDATED!", NO ERROR OCCURS ELSE THE ERROR THROWS BUT DATABASE IS STILL UPDATED.

End Sub

 

[kjv1611]

Are you sure nothing has changed on the SQL Server side? At first glance of your error messages, it sounds to me like someone changed the table structure or something... Or if there were any changes on the server itself, I imagine that could cause the issues..

Otherwise, where's the specific line in all that code where it breaks?

--

"If to err is human, then I must be some kind of human!" -Me

 

[PennyR]

Well....I was trying to keep things simple but yes, the table structure has changed some but to make sure this was not the problem I restored the databases from a year ago and used the app version from that time and got the same error without the old app changing and using the old database.

The closest I could come to finding the point of error is that it seems to be the second pass at BuildSQL called in the dgdScore_KeyPress routine:

If isUpdate Then
intCol = Me.dgdScore.Col
lngMasterID = Me.dgdScore.Columns(0).Value
HERE: Call BuildSQL
rsScore.Find ("StudentNumber = " & lngMasterID)
Me.dgdScore.Col = intCol
Me.dgdScore.SetFocus
End If


You see, whenever I add a break the app runs correctly so I cannot step through to the problem and see the error. Through try-and-error I commented out code until when commenting the 'Call BuildSQL', the app did not throw the error - but did not refresh the subform as it supposed to. When doing it by hand, the database was updated correctly.

I don't know if this helps but leaves me head-scratching.

Penny

 

[kjv1611]

Well, here's another thought. If nothing else changed between when the thing worked, and now that it is not working correctly, I'm wondering if it's some sort of network issue.

-2147417848-Automation error
The object invoked has disconnected from its clients.

That's what specifically makes me think that could be the issue. Has there been any AV changes, or firewall changes either at the enterprise, server, or client PC level that you know of, or can found out about?

--

"If to err is human, then I must be some kind of human!" -Me

 

[PennyR]

The school servers have all changed and the firewall changed but I am using my work computer that has its own version of Access and its own SQL Server on it. And, I have taken my work computer home (not on network) and the error still happens.

 

[kjv1611]

Okay, so that narrows out network issues... So it's something on the local PC for sure. Have you tried it on different PCs just to see if the error is computer related? With the server and access on the same PC? Also, have you tried with different user credentials to verify that it's not somehow tied to your profile?

--

"If to err is human, then I must be some kind of human!" -Me

 

[PennyR]

I need to follow this up tomorrow (hopefully). I loaded everything onto the network servers and ran it. They had not added the active x references when they redid the servers and now will need to add them. (neck crack one side and then the other).

Once I am able to run them on a different computer and SQL Server, I will report the results. thanks.

 

[PennyR]

I have confirmed that it is not my user credentials but I cannot get another computer to test it on yet. The active x control references have been added to the servers but they did not put VB6 on. That may not be done for a week or so.

I would still like to investigate being able to programmically close the msgbox that says 'Updated!' at the end of the event which seems to eliminate the error at all. Is there a way to do this?

 

[kjv1611]

Well, I suppose you could try this:

1. Throw up the message box.
2. Use SendKey events to simulate sending the <Enter> Key to the Message Box... I would assume you just need to set the window focus to the application/database to be sure it's active, and then send out the sendkey stroke. Being it'd only be one keystroke, hopefully you'd be okay. I suppose worst case scenerio, it'd send one <Enter> stroke to an incorrect application/shortcut, so you'd end up opening one other application - normally not a big deal. SendKeys can be messy, which is why I mention it could have some other results. However, with only one keystroke, I'd feel pretty comfortable suggesting it.

--

"If to err is human, then I must be some kind of human!" -Me