Error 3218: Could not update; currently locked - ms-access

I've been looking through the other questions related to mine, but most are about multi-user and this one came close but not quite.
System
MS Access 2013
with Linked Tables to Office 365 Sharepoint
tblQuote - frmQuote
tblQuoteItems - sbfrmQuoteItems
No Record Locks
I'm attempting to setup a select all/deselect all button that when clicked runs db.Execute Update on the tblQuoteItems where equal to Quote ID and Quote Version.
I have a button on the main form that calls the below process.
Public Sub SelectLineItems(strTable As String, strID As String, _
intID As Integer, bln As Boolean, Optional intVersion As Integer)
Dim db As Database
Dim strSQL As String
Dim strVersion As String
Set db = CurrentDb
strSQL = "UPDATE " & strTable & " SET [Selected] = "
If intVersion > 0 Then
strVersion = " AND [QuoteVersion] = " & intVersion
Else
strVersion = ""
End If
If bln Then
strSQL = strSQL + "False WHERE " & strID & " = " & intID & strVersion & ";"
Else
strSQL = strSQL + "True WHERE " & strID & " = " & intID & strVersion & ";"
End If
db.Execute strSQL, dbFailOnError
db.Close
Set db = Nothing
Exit Sub
It's pretty simple, nothing to crazy. The problem occurs when I try to run this after a record has been modified by the form and it still has focus. Because of the dbFailOnError I get the error message, If I remove dbFailOnError it will update every record except the one that has been modified through the form.
If I modify the record then select a different record manually by clicking with the mouse, the record is no longer locked and the Update works with no errors.
I have tried to replicate the process of clicking on a new record and have put the below code
If Me.Dirty Then Me.Dirty = False
In every Event I could think of like:
The subform_Current, subform_Dirty, subform.Control.Dirty/Lost_focus/subform_Before and After Update, The exit event of the subform control on the main form...etc
Placing the code in different areas doesn't make any difference, the first time the code is called it updates the record and I can confirm this in the table, the new value is present.
I've attempted to requery the subform
I've tried
DoCmd.GoToRecord , , acFirst
Then setting focus to the first control of the record.
I've even tried changing the update from the db.Execute to using a recordset object
Dim db As Dao.Database
Dim rs As Dao.Recordset
Dim strSQL As String
Dim strVersion As String
If intVersion > 0 Then
strVersion = " AND [QuoteVersion] = " & intVersion
Else
strVersion = ""
End If
strSQL = "SELECT * FROM " & strTable & " WHERE " & strID & "= " & intID & strVersion
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
With rs
Do Until .EOF
.Edit
!Selected = bln
.Update
.MoveNext
Loop
End With
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
But again it will cycle through every unlocked record and update, until it gets to the one modified by the form which then throws the same error.
I've tried opening the recordset then closing it then reopening it. But it doesn't seem to matter it's the form that's holding onto the locked record.
The only solution that has worked for me was to Set the subform recordsource to nothing, then run the update, then reset the recordsource to what it was.
The Selected column is within the QuoteItems table itself, and not in it's own table with reference to the QuoteItems ID
My question is how do I get the form to release the record through code that mimics the action of manually clicking on a new record without resetting the subform's recordsource.

Your approach with using Dirty=False is the right thing to do. But you have to apply it to the subform, as this is where the recordlock occurs. If your Code is in the Main form, you need to add this before your code to update the records.
Me.sbfrmQuoteItems.Form.Dirty = False
In that line sbfrmQuoteItems is supposed to be the name of the SubForm-Control in your main form!

Related

Access: Missing entries in the TableDef.fields collection

I'm using a VBA procedure to add some fields to an existing table by modifying its TableDef.
As the names of these fields could change between imports, I opted to delete the old entries before adding new ones.
The code below has no problem adding the fields from the library table (P6 Files AC).
Where it goes wrong is in deleting existing entries. The count at the beginning always gives the correct number of fields. But the FOR EACH statement jumps over some of the entries.
Running the code repeatedly, ultimately does delete all of the field that meet the criteria.
Set curdb = CurrentDb()
Set tdf = curdb.TableDefs("TASK")
Debug.Print tdf.Fields.Count
tdf.Fields.Refresh
For Each fld In tdf.Fields
Debug.Print fld.Name
If InStr(1, fld.Name, "AC#", vbTextCompare) > 0 Then tdf.Fields.Delete fld.Name
Next fld
'add the field from the P6 Files AC table
strSQL = "SELECT [P6 Files AC].Field_Name " & _
"FROM [P6 Files AC] " & _
"ORDER BY [P6 Files AC].Field_Name;"
Set newfields = curdb.OpenRecordset(strSQL, dbOpenSnapshot)
With newfields
Do Until .EOF()
tdf.Fields.Append tdf.CreateField(!field_name, dbText, 15)
.MoveNext
Loop
End With
I think it would be much simpler to link the source table, then use it as source in a create-table query:
SELECT *
INTO [TASK]
FROM [P6 Files AC];
It will overwrite an existing TASK table.
When you loop a collection of items, such as fields in a table, to delete them, you need to do so in reverse order, otherwise the current field positions get out of sync to those being considered in your loop. Try something like:
Sub sDeleteFields()
On Error GoTo E_Handle
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim lngCount As Long
Dim lngLoop1 As Long
Set db = CurrentDb
Set tdf = db.TableDefs("tblRatings")
lngCount = tdf.Fields.Count - 1
For lngLoop1 = lngCount To 0 Step -1
If InStr(tdf.Fields(lngLoop1).name, "AC#") > 0 Then
tdf.Fields.Delete tdf.Fields(lngLoop1).Name
End If
Next lngLoop1
tdf.Fields.Refresh
sExit:
On Error Resume Next
Set tdf = Nothing
Set db = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sDeleteFields", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Note that fields are 0-indexed, so the first field is at position 0, and the last field is at position count-1.
Regards,

listbox loads more data than it should

I have a listbox on a form which loads using the following code, which is called directly from the form_load event only once.
Private Sub LoadList()
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim strSQL As String
Dim condition As String
Set db = CurrentDb
condition = " WHERE Schedule_ID = " & ScheduleID
strSQL = "SELECT Shifts.Shift_ID, Shifts.Start_Date_Time, Shifts.End_Date_Time, Locations.Location_Name FROM Shifts, Locations " & _
"WHERE Schedule_ID = " & ScheduleID & " AND Locations.Location_ID = Shifts.Location ORDER BY Start_Date_Time"
'Set Recordset Query
Set rs = db.OpenRecordset(strSQL)
RecCount = recordCount("Shifts", condition)
Me.lblCount.Caption = "Shift Count: " & RecCount
rs.MoveFirst
For i = 0 To RecCount - 1
Me.lstShifts.AddItem rs!Shift_ID & ";" & rs!Start_Date_Time & " TO " & rs!End_Date_Time & " AT " & rs!Location_Name
rs.MoveNext
Next i
'Close Connections and Reset Variables
rs.Close
Set rs = Nothing
Set db = Nothing
listdirty = False
End Sub
There are only ten records in the database and yet the listbox loads the data three times (30 in all). I stepped through the code and on the RecCount variable it gets initialized properly to ten and the for loop iterates ten times as expected. This LoadList sub doesn't get called more than once, so I don't understand why the records are showing up in the listbox multiple times. Any ideas?
Each time your LoadList() procedure is called, it adds rows to the list box. Since the list box contains 30 rows despite the source recordset containing only 10, either LoadList() is called 3 times or you're saving the form with a non-empty value list and adding 10 more rows at each Form Load.
You could avoid that problem by emptying out the RowSource value list before the loop where you do AddItem ...
rs.MoveFirst
Me.lstShifts.RowSource = vbNullString ' make sure value list starts empty
For i = 0 To RecCount - 1
Me.lstShifts.AddItem rs!Shift_ID & ";" & rs!Start_Date_Time & " TO " & rs!End_Date_Time & " AT " & rs!Location_Name
rs.MoveNext
Next i
However you have a query which is almost what you want the list box to display. It should be simpler to revise that query and use it as the list box RowSource:
Change the list box's RowSourceType property from "Value List" to "Table/Query".
Make sure you have the list box's column count property set to 2.
In your LoadList() procedure, revise the query field list to SELECT Shifts.Shift_ID, Shifts.Start_Date_Time & ' TO ' & Shifts.End_Date_Time & ' AT ' & Locations.Location_Name
Finally, assign the updated query to the list box's RowSource property: Me.lstShifts.RowSource = strSQL

Access 2010 VBA - DAO Database connection "Operation is not supported for this type of object"

I'm really stuck. My coworkers and I cannot figure out why this database won't connect to "CurrentDb". Here's my code:
Dim db As Database, rs As DAO.Recordset
Dim strSQL As String, strRowSource As String
strSQL = "SELECT * FROM tbl_Documents"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
If rs.RecordCount = 0 Then
MsgBox "No Documents available!"
Exit Sub
End If
rs.MoveFirst
Do Until rs.EOF = True
strRowSource = strRowSource & rs!tbl_Documents.DocID & "," & rs!tbl_Document_Types.DocType & "," & rs!tbl_Documents.DocTypeID & "," & rs!tbl_Documents.DateReceived & "," & rs!tbl_Documents.LinkToFile & "," & rs!tbl_Documents.Comments & ";"
rs.MoveNext
Loop
Typically the error I get is "Item not found in this collection" during the Do Until loop. I put a watch on my database and recordset and it seems like neither are being set properly. I'm getting "Operation is not support for this type of object." in the connection field of the database object. Essentially, the exact same code is used for many other Access Databases that we have. Not sure why this won't play nice.
Looks to me like there are quiet a few changes that needs to be done to your code. As #OverMind has suggested, always declare the variables as they are. Specially libraries to avoid ambiguity in your code. Next, your strSQL includes only one table, but your strRowSource has another table. So your strSQL should be changed. I am not sure what the strRowSource does, but sounds to me like it is going to be a RowSource of a ListBox or ComboBox in that case, it is a bit confusing. Anyway your code should be.
Dim db As DAO.Database, rs As DAO.Recordset
Dim strSQL As String, strRowSource As String
strSQL = "SELECT * FROM tbl_Documents INNER JOIN tbl_Document_Types ON tbl_Documents.DocID = tbl_Document_Types.DocTypeID;"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
If rs.RecordCount = 0 Then
MsgBox "No Documents available!"
Exit Sub
End If
Do While Not rs.EOF
strRowSource = strRowSource & rs!DocID & "," & rs!DocType & "," & rs!DocTypeID & "," & rs!DateReceived & "," & rs!LinkToFile & "," & rs!Comments & ";"
rs.MoveNext
Loop
Now regarding your error. "Item not found in this collection" - could be because of the fact you were using the other fields which were not part of the recordset object. Try this code. Good luck. :)

Reference active table in split form without using actual table name

I'm writing an Access database. I have a number of forms that are identical. These are used to edit look up lists for different fields in my main contacts table.
e.g. there is a company field and a country field. The forms that open for each editable list are identical with repeat vba code in each becasue I cannot work out how to reference the active table from the active form.
The code I currently have for clearing all the yes/no boxes in the table is:
Private Sub cmdClearTicks_Click()
Dim db As Database
' Dim sel As Control
Set db = CurrentDb
' Clear all ticks of selected records
db.Execute "UPDATE ContactCompany " _
& "SET Selected = null "
' Update Selected Field
Me.Requery
End Sub
ContactCompany is the name of the table. I would like to be able to set this sub globally but cannot work out what I should replace ContactCompany with to reference the table in the currently open form. I've already tried Me.RecordSource which does not work.
I'm very grateful for what I assume is a very easy fix!
Sean posted a great fix below. I'm now stumped with including a filter too and defining it globaly.
Sub SelectFiltered(RS As String)
Dim strFilter As String
Dim strSQl As String
If InStr(RS, "FROM") Then
RS = Mid(RS, InStr(RS, "FROM") + 5)
If InStr(RS, " ") Then RS = Left(RS, InStr(RS, " ") - 1)
End If
strFilter = Me.Filter
If Me.FilterOn = False Then
'Select Case MsgBox("No search or filter applied.", vbCritical + vbOKOnly, "Warning")
'End Select
strSQl = "UPDATE " & RS & " " & _
"SET Selected = 1 "
Else
strSQl = "UPDATE " & RS & " " & _
"SET Selected = 1 " & _
"WHERE " & strFilter
End If
DoCmd.SetWarnings False
DoCmd.RunSQL strSQl
DoCmd.SetWarnings True
End Sub
Me.filter doesn't work in the global sub. Sean - I'm sure you'll have an answer for this in a sec. Thanks again!
you are close with using Me.Recordsource
db.Execute "UPDATE " & Me.Recordsource & " SET Selected = null "
or, if you want it as a global function, pass Me.Recordsource to it
Sub ClearTicks(RS as string,StrFilter as string)
Dim db As Database
Set db = CurrentDb
If InStr(RS, "FROM") Then
RS = Mid(RS, InStr(RS, "FROM") + 5)
If InStr(RS, " ") Then RS = Left(RS, InStr(RS, " ") - 1)
End If
' Clear all ticks of selected records
db.Execute "UPDATE " & RS & " SET Selected = null "
If StrFilter="" then 'no filter
Else 'filter
End If
End Sub
and your calling function would be:
Private Sub cmdClearTicks_Click()
ClearTicks Me.Recordsource,Me.Filter
Me.Refresh
End Sub
If you want a more reusable function method that could be expanded more easily, then call the sub/function with Me.Name as the parameter (e.g. MySub Me.Name) and then in your reusable function:
sub MySub(FrmName as string)
Forms(FrmName).Filter
Forms(FrmName).Recordsource
Forms(FrmName).AnyOtherParamater

Access VBA Loop through Query help

I have a form (Cobind_frmMain) that allows the user to create a pool of titles that are attached to it. So there is a top level Pool Name (TopLvlPoolName) and on a subform, the titles are added to it. What I need is to issue a Report for each of the titles. I have the report and queries all set up. Right now, the report will show all the titles in one file. The titles are in a field called "CatCode".
What I need is the following:
1. Save each title as a PDF and save it to our server.
2. Open email and attach the PDF.
3. Repeat until all titles are done.
EDIT: This is what I have so far for code and the error message I still get is: "Too Few Parameters" on the Set Recordset line. I'm trying to set the parameter in the strSQL line. I want the PartPoolName (in Cobind_qryReport, a query) to equal the TopLvlPoolName on the open form. The SQL for Cobind_qryReport is listed below:
Private Sub btn_Run_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Set db = CurrentDb
strSQL = "Select * FROM Cobind_qryReport WHERE PartPoolName = " & Me.TopLvlPoolName
Set rs = db.OpenRecordset(strSQL)
On Error GoTo Err_PO_Click
If MsgBox("Do you wish to issue the cobind invites?", vbYesNo + vbQuestion, "Confirmation Required") = vbYes Then
rs.MoveFirst
Do While Recordset.EOF = False
DoCmd.OutputTo acOutputReport, "Cobind_rptMain", acFormatPDF, "K:\OB MS Admin\Postage\CoBind Opportunities\Sent Invites\" & [CatCode] & "_" & [PartPoolName] & "Cobind Invite_" & Format(Now(), "mmddyy") & ".pdf"
DoCmd.SendObject acSendReport, "Cobind_rptMain", acFormatPDF, , , , [CatCode] & "_" & [PartPoolName] & " Cobind Invite", "Please find the cobind invite attached. Response is needed by " & [RSVP] & ". Thank you.", True
Recordset.MoveNext
Loop
End If
Exit_PO_Click:
MsgBox ("It didn't work")
Exit Sub
Err_PO_Click:
MsgBox Err.Description
Resume Exit_PO_Click
End Sub
Cobind_qryReport SQL:
SELECT tblEvents.EventTitle, Cobind_tblPartic.CatCode, Cobind_tblPartic.CodeQty, Cobind_tblPartic.PartPoolName, Cobind_tblTopLvl.RSVP, Cobind_tblPartic.ID
FROM Cobind_tblTopLvl, Cobind_tblPartic INNER JOIN tblEvents ON Cobind_tblPartic.CatCode = tblEvents.EventCode
GROUP BY tblEvents.EventTitle, Cobind_tblPartic.CatCode, Cobind_tblPartic.CodeQty, Cobind_tblPartic.PartPoolName, Cobind_tblTopLvl.RSVP, Cobind_tblPartic.ID
ORDER BY Cobind_tblPartic.ID;
Thank you again for all your help!
You're query Cobind_qryReport has a parameter that you need to set. if you want to know the parameter name try the following code
Dim qdf As QueryDef
Set qdf = CurrentDb.QueryDefs("Cobind_qryReport")
If qdf.Parameters.Count > 0 Then
MsgBox (qdf.Parameters(0).Name)
End If
Update
Since you know you've got a parameter doing select * from Cobind_qryReport it might just be easier to set the parameter and then use the qdf to open the recordset e.g.
Dim rs as DAO.Recordset
Dim qdf As QueryDef
Set qdf = CurrentDb.QueryDefs("Cobind_qryReport")
qdf.Parameters(0).Value = 7832
Set foo = qdf.OpenRecordset()
Note: you can use the parameter name in the place of the ordinal when setting the parametervalue
e.g. qdf.Parameters("Foo").value = 7832