Run-Time Error 3008 when trying to run a delete query. Error is saying that the table records it is trying to delete is already open? - vba

This code below is giving me a runtime error stating the table is already open by another user, when I am trying to execute a delete query. It is only giving me this error on this delete query when I am trying to run it strictly through vba, but if i try to run it manually It works as it is designed too? Also, if I comment out this delete query I end up having no issues?
Private Sub Command27_Click()
Dim dbs As dao.Database
Dim Response As Integer
Dim strSQL As String
Dim Query1 As String
Dim LTotal As String
Dim Excel_App As Excel.Application 'Creates Blank Excel File
Dim strTable As String ' Table in access
LTotal = DCount("*", "tbPrintCenter03 RequestedToPrint", "Assigned= True")
Select Case MsgBox("There are (" & LTotal & ") record(s) selected to be
printed." & vbNewLine & " Do you wish to continue?", vbQuestion + vbYesNo,
"Mark as Printed?")
'If yes is Clicked
Case vbYes
Assigned = True 'Changes from false to True
Assigned_User52 = fOSUserName 'Assigns their 5&2
Assigned_Date = Date + Time 'Gets timestamp
'Updates the Global Table in SQL
DoCmd.SetWarnings False
DoCmd.OpenQuery "Qry_UpdateMasterfrom04", acViewNormal, acEdit
DoCmd.OpenQuery "Qry_AppendTo05Que", acViewNormal, acEdit
DoCmd.OpenQuery "Qry_DeletePrinted", acViewNormal, acEdit
''Run-Time error 3006 is happening on this line of code
DoCmd.Close acForm, "tbPrintCenter_Main", acSaveYes 'Save and Close
DoCmd.OpenForm ("tbPrintCenter_Main") 'Opens Form
'-------------------------------------------------------------------------------
'Reference Only
' DoCmd.GoToRecord , , acNext 'Goes to next record
' ' DoCmd.GoToRecord , , acNext
'-------------------------------------------------------------------------------
strTable = "tbPrintCenter05Que" 'Access Table I am trying to copy
Set Excel_App = CreateObject("Excel.Application")
Set dbs = CurrentDb
Dim rs As dao.Recordset
Set rs = dbs.OpenRecordset(strTable)
Excel_App.Visible = True
Dim wkb As Excel.Workbook
Set wkb = Excel_App.Workbooks.Add
Dim rg As Excel.Range
Dim i As Long
' Add the headings
For i = 0 To rs.Fields.Count - 1
wkb.Sheets(1).Cells(1, i + 1).Value = rs.Fields(i).Name
Next i
Set rg = wkb.Sheets(1).Cells(2, 1)
rg.CopyFromRecordset rs
' make pretty
rg.CurrentRegion.EntireColumn.AutoFit
DoCmd.OpenQuery "Qry_DeleteRecordsFrom05", acViewNormal, acEdit
Response = MsgBox("Updated to an assigned user!", vbInformation + vbOKOnly)
'MsgBox Update Complete
DoCmd.SetWarnings True
Exit Sub
'If no is clicked
Case vbNo
Response = MsgBox("No actions are performed!", vbInformation)
Exit Sub
End Select
End Sub
Following the link provided you will see the code I am using bits and pieces ofr on. Any advice?
https://stackoverflow.com/a/58732371/10226211

Related

Duplicate form button with multivalued field and subform

I am trying to duplicate a form from a button using vba. This has worked for years using Allen Browne's "Duplicate the record in form and subform." http://allenbrowne.com/ser-57.html
Now I want to change one of the fields to multivalue. I understand the difficulties with multivalued fields, but this is a 10 year old database and all I need to do is make this field be able to store multiple values, so think this will be easier than creating a new join table and updating everything related.
I am currently getting Invalid use of Property at the rstmv = rstmv.Value line.
I have tried numerous versions and get different errors. I think I should be opening the values of the multi-value field as a separate recordset, updating it then looping through the values but I am getting confused as I am not really sure what I am doing.
Here is the code I I have been using:
'On Error GoTo Err_Handler
'Purpose: Duplicate the main form record and related records in the subform.
Dim strSql As String 'SQL statement.
Dim lngID As Long 'Primary key value of the new record.
Dim rst As Recordset
Dim rstmv As Recordset2
'Save and edits first
If Me.Dirty Then
Me.Dirty = False
End If
'Make sure there is a record to duplicate.
If Me.NewRecord Then
MsgBox "Select the record to duplicate."
Else
'Duplicate the main record: add to form's clone.
With Me.RecordsetClone
.AddNew
!Site_Name = Me.Site_Name
!Date_of_Dive = Me.Date_of_Dive
!Time_of_Dive = Me.Time
Set rst = Me.RecordsetClone
Set rstmv = rst!Staff.Value
Do While Not rstmv.EOF
rsp.Edit
rstmv.Edit
rstmv.AddNew ' Add a new record to the asp Recordset
rstmv = rstmv.Value
rstmv.Update ' Commit the changes to the asp Recordset
imt.MoveNext
Loop
.Update
!O2 = Me.O2
!First_Aid = Me.First_Aid
!Spares = Me.Spares
'etc for other fields.
.Update
'Save the primary key value, to use as the foreign key for the related records.
.Bookmark = .LastModified
lngID = !Dive_Number
'Duplicate the related records: append query.
If Me.[DiveDetailssubform].Form.RecordsetClone.RecordCount > 0 Then
strSql = "INSERT INTO [DiveDetails] (Dive_Number, CustDateID, Type, Price) " & _
"SELECT " & lngID & " As NewID, CustDateID, Type, Price " & _
"FROM [DiveDetails] WHERE Dive_Number = " & Me.Dive_Number & ";"
DBEngine(0)(0).Execute strSql, dbFailOnError
Else
MsgBox "Main record duplicated, but there were no related records."
End If
'Display the new duplicate.
Me.Bookmark = .LastModified
MsgBox "Dive Sucessfully Duplicated. DONT FORGET TO CHANGE THE SITE NAME."
End With
End If
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description, , "Duplicate_Click"
Resume Exit_Handler
End Sub
Private Sub Form_Load()
Dim varID As Variant
Dim strDelim As String
'Note: If CustomerID field is a Text field (not a Number field), remove single quote at start of next line.
'strDelim = """"
varID = DLookup("Value", "tblSys", "[Variable] = 'DiveIDLast'")
If IsNumeric(varID) Then
With Me.RecordsetClone
.FindFirst "[dive_number] = " & strDelim & varID & strDelim
If Not .NoMatch Then
Me.Bookmark = .Bookmark
End If
End With
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim rs As DAO.Recordset
If Not IsNull(Me.Dive_Number) Then
Set rs = CurrentDb().OpenRecordset("tblSys", dbOpenDynaset)
With rs
.FindFirst "[Variable] = 'DiveIDLast'"
If .NoMatch Then
.AddNew 'Create the entry if not found.
![Variable] = "DiveIDLast"
![Value] = Me.Dive_Number
![Description] = "Last DiveID, for form Dive Planner" & Me.Name
.Update
Else
.Edit 'Save the current record's primary key.
![Value] = Me.Dive_Number
.Update
End If
End With
rs.Close
End If
Set rs = Nothing
End Sub
Need recordsets of source data and recordsets for destination. Also should explicitly declare the recordset type as DAO. Consider:
Dim strSql As String 'SQL statement.
Dim lngID As Long 'Primary key value of the new record.
Dim rstF As DAO.Recordset
Dim rstT As DAO.Recordset
Dim rstmvF As DAO.Recordset2
Dim rstmvT As DAO.Recordset2
'Save any edits first
If Me.Dirty Then
Me.Dirty = False
End If
'Make sure there is a record to duplicate.
If Me.NewRecord Then
MsgBox "Select the record to duplicate."
Else
Set rstF = CurrentDb.OpenRecordset("SELECT * FROM Dives WHERE Dive_Number = " & Me.Dive_number)
Set rstmvF = rstF!Staff.Value
'Duplicate the main record: add to form's clone.
With Me.RecordsetClone
.AddNew
!Site_Name = Me.Site_Name
!Date_of_Dive = Me.Date_of_Dive
!Time_of_Dive = Me.Time
!O2 = Me.O2
!First_Aid = Me.First_Aid
!Spares = Me.Spares
.Update
'Save the primary key value of new record.
.Bookmark = .LastModified
lngID = !Dive_number
Set rstT = CurrentDb.OpenRecordset("SELECT * FROM Dives WHERE Dive_Number = " & lngID)
Set rstmvT = rstT!Staff.Value
rstT.Edit
Do While Not rstmvF.EOF
rstmvT.AddNew ' Add a new record to the asp Recordset
rstmvT!Value = rstmvF!Value
rstmvT.Update ' Commit the changes to the asp Recordset
rstmvF.MoveNext
Loop
rstT.Update

ListBox Multiselect in MS Access

I have created a form to get all the field header names, but I'm unable to select multiple fields. Attached is for your reference.
Following is the code used to get the Headers from the Master Table:
Private Sub Form_Load()
'Call GetColumnNameFromIndex
'Call List4_Click
Dim rst As New ADODB.Recordset
rst.Open "SELECT * FROM Master_DataBase", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
' Note: adOpenForwardOnly and adLockReadOnly are the default values '
' for the CursorType and LockType arguments, so they are optional here '
' and are shown only for completeness '
Dim ii As Integer
Dim ss As String
For ii = 0 To rst.Fields.Count - 1
ss = ss & "," & rst.Fields(ii).Name
Next ii
Me.List4.RowSource = ss
Debug.Print ss
Me.Requery
End Sub
Set your properties to Simple or Extended.
Sample VBA code may look like this.
Option Compare Database
Private Sub cmdOpenQuery_Click()
On Error GoTo Err_cmdOpenQuery_Click
Dim MyDB As DAO.Database
Dim qdef As DAO.QueryDef
Dim i As Integer
Dim strSQL As String
Dim strWhere As String
Dim strIN As String
Dim flgSelectAll As Boolean
Dim varItem As Variant
Set MyDB = CurrentDb()
strSQL = "SELECT * FROM tblCompanies"
'Build the IN string by looping through the listbox
For i = 0 To lstCounties.ListCount - 1
If lstCounties.Selected(i) Then
If lstCounties.Column(0, i) = "All" Then
flgSelectAll = True
End If
strIN = strIN & "'" & lstCounties.Column(0, i) & "',"
End If
Next i
'Create the WHERE string, and strip off the last comma of the IN string
strWhere = " WHERE [strCompanyCountries] in (" & Left(strIN, Len(strIN) - 1) & ")"
'If "All" was selected in the listbox, don't add the WHERE condition
If Not flgSelectAll Then
strSQL = strSQL & strWhere
End If
MyDB.QueryDefs.Delete "qryCompanyCounties"
Set qdef = MyDB.CreateQueryDef("qryCompanyCounties", strSQL)
'Open the query, built using the IN clause to set the criteria
DoCmd.OpenQuery "qryCompanyCounties", acViewNormal
'Clear listbox selection after running query
For Each varItem In Me.lstCounties.ItemsSelected
Me.lstCounties.Selected(varItem) = False
Next varItem
Exit_cmdOpenQuery_Click:
Exit Sub
Err_cmdOpenQuery_Click:
If Err.Number = 5 Then
MsgBox "You must make a selection(s) from the list", , "Selection Required !"
Resume Exit_cmdOpenQuery_Click
Else
'Write out the error and exit the sub
MsgBox Err.Description
Resume Exit_cmdOpenQuery_Click
End If
End Sub
Please customize to your specific needs.

Open saved rtf document with MS Access

I have some code that exports queries and saves the document as a rich-text file:
DoCmd.OutputTo acReport, "rptEvents", "RichTextFormat(*.rtf)", "C:\SARPCCO_Database\SARPCCO_Report.rtf"
How can I open the saved document wih the same export button?
The full code behind this button is:
Private Sub CommandExport_Click()
On Error GoTo Err_CommandExport_Click
Dim db As Database
Dim qdf As QueryDef
Dim strSql As String
'Dim rsCriteria As Recordset
Dim strWhere As Recordset
Set db = CurrentDb
Set strWhere = db.OpenRecordset("qryEvents", dbOpenDynaset)
'*** the first record in the Criteria table ***
strWhere.MoveFirst
'*** loop to move through the records in Criteria table
'Do Until strWhere.EOF
'*** create the Select query based on
' the first record in the Criteria table
strSql = "SELECT * FROM qryEvents WHERE "
strSql = strSql & "[Event_ID] = " & strWhere![Event_ID]
'*** delete the previous query
'db.QueryDefs.Delete "qryEvents2"
'Set qdf = db.CreateQueryDef("qryEvents2", strSql)
DoCmd.OutputTo acReport, "rptEvents", "RichTextFormat(*.rtf)", "C:\SARPCCO_Database\SARPCCO_Report.rtf"
Documents.Open Filename:="C:\SARPCCO_Database\SARPCCO_Report.rtf", ReadOnly:=False
strWhere.MoveNext
'Loop
Exit_CommandExport_Click:
Exit Sub
Err_CommandExport_Click:
MsgBox "The file SARPCCO_Report you want to export to doest not exists." & vbCrLf & vbLf & _
"Please, ensure the file is in the right place before attempting to export your report", vbExclamation + vbOKOnly, "Report exporting error"
Resume Exit_CommandExport_Click
End Sub
Thank you GOOGLE, I found a working code:
Dim WordApp As Object
Dim WordDoc As Object
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(Filename:="C:\MyFiles\Test.rtf", ReadOnly:=False)
WordApp.Visible = True
'do your stuff
Set WordDoc = Nothing
Set WordApp = Nothing
Append a True for AutoOpen:
DoCmd.OutputTo acReport, "rptEvents", "RichTextFormat(*.rtf)", "C:\SARPCCO_Database\SARPCCO_Report.rtf", True

Using VBA for attachments

I'm trying to use VBA to attach a file to an existing table but I keep running into a Runtime 3709 error as documented on the line below. I have a table with a few thousand files in it. What I would like to do is give the user the ability to select the file to be attached and when it's saved, the name will show up on the form. Any help would be appreciated. Thanks.
Dim rsParent As DAO.Recordset
Dim rsAttachment As DAO.Recordset2
Dim strFileName As String
Dim SQL As String
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.Title = "Choose the document to add to the form..."
.AllowMultiSelect = False
.InitialFileName = "C:\Users\"
If .Show = True Then
If .SelectedItems.Count = 0 Then
GoTo SubExit
End If ''
For Each varFile In .SelectedItems
strFileName = varFile
Next
Else
GoTo SubExit
End If
End With
SQL = "SELECT * FROM tblTable WHERE RecordID = " & Me.tbxRecordID
'Instantiate the parent recordset
Set rsParent = CurrentDb.OpenRecordset(SQL, dbOpenDynaset) ''
If rsParent.recordCount = 0 Then
MsgBox "There was a problem locating the selected record", vbCritical +
vbOKOnly, "Error"
GoTo SubExit
Else
' Put recordset in edit mode
rsParent.Edit
'Set the child recordset
Set rsAttachment = rsParent.Fields("Document").Value '**Runtime 3709 -
Search key not found**
'Add new attachment
rsAttachment.AddNew
rsAttachment.Fields("FileData").LoadFromFile strFileName
rsAttachment.Update
rsParent.Update
frmAttachments.Requery
End If
SubExit:
On Error Resume Next
If Not rsParent Is Nothing Then
rsParent.Close
Set rsParent = Nothing
End If
Exit Sub '
SubError:
MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit '
End Sub

SQL query to extract employee details from access table

I am new to Excel VBA. I have a user form in which I am trying to populate names of those employees who are AMO. I have a database called Ofc. Under which I have a table EmployeeDetails. Primary key is PeoplesoftId.
Here is the structure and the contents of the Employee table:
PeoplesoftId Nameofemployee RacifId Employeeid Designation
43243309 Maddala V43309 99651823 AMO
43243310 Abhishek A43301 99651824 AMO
43243311 Atanu A43311 99651825 MO
43243312 Rajiv R43312 99651826 CSE
This is the code I've written so far:
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rs As ADODB.Recordset 'dim the ADO recordset class
Dim dbPath As String
Dim SQL As String
Dim i As Integer
Dim var
'add error handling
On Error GoTo errHandler:
'Disable screen flickering.
Application.ScreenUpdating = False
dbPath = "E:\office_hsbc\ofc.accdb"
var = "AMO"
Set cnn = New ADODB.Connection ' Initialise the collection class variable
cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
cnn.Open
SQL = "SELECT Nameofemployee FROM EmployeeDetails where Designation= '" & var & "'"
Set rs = New ADODB.Recordset 'assign memory to the recordset
rs.Open SQL, cnn
If rs.EOF And rs.BOF Then
rs.Close
cnn.Close
'clear memory
Set rs = Nothing
Set cnn = Nothing
'Enable the screen.
Application.ScreenUpdating = True
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
For i = 0 To rs.Fields.Count - 1
comboamo.AddItem rs.Fields(i).Value, i
Next
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
MsgBox "Congratulation the data has been successfully Imported", vbInformation, "Import successful"
'error handler
On Error GoTo 0
Exit Sub
errHandler:
'clear memory
Set rs = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Import_Data"
You need to move through each record in the recordset. Currently you are trying to read all of the fields from a single record but your query only returns one field. Try this instead:
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
i = 0
Do Until rs.EOF
comboamo.AddItem rs.Fields("Nameofemployee").Value, i
rs.MoveNext
i = i + 1
Loop
rs.Close