Hi all wonder if you could advise on this problem I am having with a database I inherited. Not experienced with code so not sure why I'm getting this runtime error
Usual kind of thing, click a button data imported from CSV which should be being updated/appended to tables.
It initially looks as though it is working part from it doesn't update or append any data and it only throws it dummy out the pram when stepping through the code...
It gets as far as the rs.open statement in bold then seems throws this runtime error '-2147467259 (80004005)', locked by user 'Admin' on 'My Laptop ID' that prevents it from being opened or locked. I'm working on a local copy so no one else is on it.
the code is: (i've left the stuff in that was commented out so you can see the full picture)
===================================
Private Sub CmdImportVldtnRqsts_Click()
Dim Filename As String
Dim myNewStatusID As Long
myNewStatusID = 6
'Dim MyWithdrawalTypeID As Long
'Dim MyWithdrawalStatusID As Long
'Dim MyWithdrawalSourceID As Long
'MyWithdrawalTypeID = 0
'MyWithdrawalStatusID = 1
'MyWithdrawalSourceID = 2
On Error Resume Next
Filename = GetFile("*.csv", CodeProject.Path, "Please select a file to open", "*CTSUValidationImport.csv")
Select Case Right(Filename, 4)
Case ".csv"
DoCmd.TransferText acImportDelim, , "CTSUValidationImport", Filename, True
'Case ".xls"
' DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "CTSUValidationImport", Filename, True
Case Else
MsgBox "Only files of type CSV and XLS are supported for this.", vbOKOnly, "Sorry, can't help"
Exit Sub
End Select
On Error GoTo 0
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
'rs.Open "select * from CTSUValidationImport where WithdrawalUpdated=False AND isdate(RemovedFromODIN)", Application.CodeProject.BaseConnectionString, adOpenForwardOnly, adLockOptimistic
rs.Open "select * from CTSUValidationImport where WithdrawalUpdated=False AND UCase(Correct)='Y' AND UCase(Checked)='Y'", Application.CodeProject.BaseConnectionString, adOpenForwardOnly, adLockOptimistic
DoCmd.SetWarnings True
If Not rs.EOF Then
Do While Not rs.EOF
myPID = rs.Fields("PID")
If Not IsNull(myPID) Then
myWithdrawalID = rs.Fields("WithdrawalID")
myImportDate = rs.Fields("ImportDate")
myPID = rs.Fields("PID")
myFirstName = rs.Fields("FirstName")
myLastName = rs.Fields("LastName")
myDob = rs.Fields("DoB")
myTelephone = rs.Fields("Telephone")
myAddress1 = rs.Fields("Address1")
myAddress2 = rs.Fields("Address2")
myAddress3 = rs.Fields("Address3")
myAddress4 = rs.Fields("Address4")
myAddress5 = rs.Fields("Address5")
myPostCode = rs.Fields("Postcode")
'myODINDate = rs.Fields("RemovedFromODIN")
myNotes = rs.Fields("Notes")
'Update Withdrawal record
myUpdWithlSQL = "Update Withdrawal Set WithdrawalStatusID=" & myNewStatusID & " "
myUpdWithlSQL = myUpdWithlSQL & ", Notes=""" & myNotes & """ Where ID=" & myWithdrawalID
DoCmd.RunSQL myUpdWithlSQL
myUpdWithlSQL = "Insert into WithdrawalStatus_log (WithdrawalID,WithdrawalStatusID, UserID) Values (" & myWithdrawalID & ", " & myNewStatusID & ", " & UserID & ")"
DoCmd.RunSQL myUpdWithlSQL
'Update participant record
myUpdPtSQL = "Update Participant Set PID=" & myPID
myUpdPtSQL = myUpdPtSQL & ", FirstName='" & myFirstName & "'"
myUpdPtSQL = myUpdPtSQL & ", LastName='" & myLastName & "'"
If IsDate(myDob) Then
myUpdPtSQL = myUpdPtSQL & ", DoB=#" & myDob & "#"
End If
myUpdPtSQL = myUpdPtSQL & ", Telephone='" & myTelephone & "'"
myUpdPtSQL = myUpdPtSQL & ", Address1=""" & myAddress1 & """"
myUpdPtSQL = myUpdPtSQL & ", Address2=""" & myAddress2 & """"
myUpdPtSQL = myUpdPtSQL & ", Address3=""" & myAddress3 & """"
myUpdPtSQL = myUpdPtSQL & ", Address4=""" & myAddress4 & """"
myUpdPtSQL = myUpdPtSQL & ", Address5=""" & myAddress5 & """"
myUpdPtSQL = myUpdPtSQL & ", Postcode='" & myPostCode & "'"
myUpdPtSQL = myUpdPtSQL & " WHERE WithdrawalID=" & myWithdrawalID & " AND PID=" & myPID
DoCmd.RunSQL myUpdPtSQL
'DoCmd.RunSQL TmpPartID
UpdateImportSQL = "Update CTSUValidationImport set WithdrawalUpdated= true WHERE WithdrawalID=" & myWithdrawalID & " AND PID=" & myPID
DoCmd.RunSQL UpdateImportSQL
End If
rs.MoveNext
Loop
End If
DoCmd.SetWarnings True
rs.Close
Set rs = Nothing
MsgBox "CTSU Data has been imported", vbOKOnly, "Confirmation"
Me.Requery
'DoCmd.RunSQL "Select"
'Debug.Print Filename
End Sub
===========================
Thanks in anticipation for advice etc
Steve
Usual kind of thing, click a button data imported from CSV which should be being updated/appended to tables.
It initially looks as though it is working part from it doesn't update or append any data and it only throws it dummy out the pram when stepping through the code...
It gets as far as the rs.open statement in bold then seems throws this runtime error '-2147467259 (80004005)', locked by user 'Admin' on 'My Laptop ID' that prevents it from being opened or locked. I'm working on a local copy so no one else is on it.
the code is: (i've left the stuff in that was commented out so you can see the full picture)
===================================
Private Sub CmdImportVldtnRqsts_Click()
Dim Filename As String
Dim myNewStatusID As Long
myNewStatusID = 6
'Dim MyWithdrawalTypeID As Long
'Dim MyWithdrawalStatusID As Long
'Dim MyWithdrawalSourceID As Long
'MyWithdrawalTypeID = 0
'MyWithdrawalStatusID = 1
'MyWithdrawalSourceID = 2
On Error Resume Next
Filename = GetFile("*.csv", CodeProject.Path, "Please select a file to open", "*CTSUValidationImport.csv")
Select Case Right(Filename, 4)
Case ".csv"
DoCmd.TransferText acImportDelim, , "CTSUValidationImport", Filename, True
'Case ".xls"
' DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "CTSUValidationImport", Filename, True
Case Else
MsgBox "Only files of type CSV and XLS are supported for this.", vbOKOnly, "Sorry, can't help"
Exit Sub
End Select
On Error GoTo 0
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
'rs.Open "select * from CTSUValidationImport where WithdrawalUpdated=False AND isdate(RemovedFromODIN)", Application.CodeProject.BaseConnectionString, adOpenForwardOnly, adLockOptimistic
rs.Open "select * from CTSUValidationImport where WithdrawalUpdated=False AND UCase(Correct)='Y' AND UCase(Checked)='Y'", Application.CodeProject.BaseConnectionString, adOpenForwardOnly, adLockOptimistic
DoCmd.SetWarnings True
If Not rs.EOF Then
Do While Not rs.EOF
myPID = rs.Fields("PID")
If Not IsNull(myPID) Then
myWithdrawalID = rs.Fields("WithdrawalID")
myImportDate = rs.Fields("ImportDate")
myPID = rs.Fields("PID")
myFirstName = rs.Fields("FirstName")
myLastName = rs.Fields("LastName")
myDob = rs.Fields("DoB")
myTelephone = rs.Fields("Telephone")
myAddress1 = rs.Fields("Address1")
myAddress2 = rs.Fields("Address2")
myAddress3 = rs.Fields("Address3")
myAddress4 = rs.Fields("Address4")
myAddress5 = rs.Fields("Address5")
myPostCode = rs.Fields("Postcode")
'myODINDate = rs.Fields("RemovedFromODIN")
myNotes = rs.Fields("Notes")
'Update Withdrawal record
myUpdWithlSQL = "Update Withdrawal Set WithdrawalStatusID=" & myNewStatusID & " "
myUpdWithlSQL = myUpdWithlSQL & ", Notes=""" & myNotes & """ Where ID=" & myWithdrawalID
DoCmd.RunSQL myUpdWithlSQL
myUpdWithlSQL = "Insert into WithdrawalStatus_log (WithdrawalID,WithdrawalStatusID, UserID) Values (" & myWithdrawalID & ", " & myNewStatusID & ", " & UserID & ")"
DoCmd.RunSQL myUpdWithlSQL
'Update participant record
myUpdPtSQL = "Update Participant Set PID=" & myPID
myUpdPtSQL = myUpdPtSQL & ", FirstName='" & myFirstName & "'"
myUpdPtSQL = myUpdPtSQL & ", LastName='" & myLastName & "'"
If IsDate(myDob) Then
myUpdPtSQL = myUpdPtSQL & ", DoB=#" & myDob & "#"
End If
myUpdPtSQL = myUpdPtSQL & ", Telephone='" & myTelephone & "'"
myUpdPtSQL = myUpdPtSQL & ", Address1=""" & myAddress1 & """"
myUpdPtSQL = myUpdPtSQL & ", Address2=""" & myAddress2 & """"
myUpdPtSQL = myUpdPtSQL & ", Address3=""" & myAddress3 & """"
myUpdPtSQL = myUpdPtSQL & ", Address4=""" & myAddress4 & """"
myUpdPtSQL = myUpdPtSQL & ", Address5=""" & myAddress5 & """"
myUpdPtSQL = myUpdPtSQL & ", Postcode='" & myPostCode & "'"
myUpdPtSQL = myUpdPtSQL & " WHERE WithdrawalID=" & myWithdrawalID & " AND PID=" & myPID
DoCmd.RunSQL myUpdPtSQL
'DoCmd.RunSQL TmpPartID
UpdateImportSQL = "Update CTSUValidationImport set WithdrawalUpdated= true WHERE WithdrawalID=" & myWithdrawalID & " AND PID=" & myPID
DoCmd.RunSQL UpdateImportSQL
End If
rs.MoveNext
Loop
End If
DoCmd.SetWarnings True
rs.Close
Set rs = Nothing
MsgBox "CTSU Data has been imported", vbOKOnly, "Confirmation"
Me.Requery
'DoCmd.RunSQL "Select"
'Debug.Print Filename
End Sub
===========================
Thanks in anticipation for advice etc
Steve
