I am using a listbox to navigate between records on a form but I occasionally get Error Update or CancelUpdate without AddNew or Edit Run-time Error 3020
on Me.Bookmark = rs.Bookmark.
I can't seems to figure out what the problem is and was wondering if someone can help me with how to fix it.
Option Compare Database
Option Explicit
Dim rs As DAO.Recordset
Private Sub listBox_AfterUpdate()
Dim rs As DAO.Recordset
If Not IsNull(ItemNo) And Not IsNull(itemName) Then
Set rs = Me.RecordsetClone
rs.FindFirst "[ItemNo] = '" & Me![listBox] & "'"
If Not rs.NoMatch Then Me.Bookmark = rs.Bookmark
Else
Exit Sub
End If
If IsNull(ItemNo) Or IsNull(itemName) Then
Exit Sub
End If
rs.Close
Set rs = Nothing
End Sub
You have probably started to edit the record in the Form. Save the pending edits before moving to another record.
If Not rs.NoMatch Then
Me.Dirty = False 'Saves any pending changes.
Me.Bookmark = rs.Bookmark 'Navigate to another record.
End If
Related
I have a VBA script and I need to create forms based on distinct LocationIDs in a table. So for every row with LocationID = 1 create a form with the name of that location represented in the title of the form, "formLocation1". Then for each LocationID = 2, create another form with the name of that one in the title, "formLocation2", etc. What is the best way to do this using DoCmd.OpenForm"" in the VBA script?
You can try something like this.
Loop through a recordset, and create a form for each LocationID using the CreateForm() method. You can then set the Form's .Caption property to "formLocation(LocationID)".
(Change T to the name of your table).
Public Sub CreateForms()
On Error GoTo ex
Dim rs As DAO.Recordset
Set rs = CurrentDb().OpenRecordset("SELECT DISTINCT LocationID FROM T ORDER BY LocationID;", dbOpenSnapshot)
With rs
If .EOF Then GoTo out
.MoveLast
.MoveFirst
End With
Dim frm As Access.Form, i As Integer
For i = 1 To rs.RecordCount
Set frm = CreateForm()
frm.Caption = "formLocation" & rs![LocationID]
DoCmd.Close acForm, frm.Name, acSaveYes
Set frm = Nothing
rs.MoveNext
Next i
out:
On Error Resume Next
rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Sub
ex:
MsgBox Err.Description, vbCritical
Resume out
End Sub
I am attempting to add a VBA to a command button to look at a text box and if not null, then look at a combo box. If that combo box is null, have a pop up message box. Since it is a continuous form and there are several records showing, it works fine on the first record, however it does not for the following records. I believe this is because I need to loop through each record. Below is the VBA code I have so far. I would greatly appreciate any help regarding the loop, as I am new to VBA.
If Not IsNull(Me.Text33.Value) Then
If IsNull(Me.Combo24.Value) Then
MsgBox "You must state if the rationale is aligned with procedures for each disputed subcategory."
Else
'do nothing
End If
End If
DoCmd.Save
DoCmd.Close
Thank you in advance,
Susan
Since this is a continuous form, you can Clone the Form's recordset and loop in each record.
Dim rs As DAO.Recordset
Set rs = Me.RecordsetClone
rs.MoveLast
rs.MoveFirst
Dim idx As Integer
For idx = 1 To rs.RecordCount
If Not IsNull(rs![TextBoxFieldName]) Then If IsNull(rs![ComboBoxFieldName]) Then MsgBox "..."
rs.MoveNext
Next idx
Set rs = Nothing
With DoCmd
.Save
.Close
End With
Note in case this is intended for validation purposes, the DoCmd actions will always execute regardless of the message-box error/warning.
You can change that by adding an Exit Sub after showing the message box.
Edit:
Sub Example()
Dim rs As DAO.Recordset
Set rs = Me.RecordsetClone
rs.MoveLast
rs.MoveFirst
Dim idx As Integer
For idx = 1 To rs.RecordCount
Select Case True
Case Not IsNull(rs![ComboFieldName]) And IsNull(rs![TextBoxFieldName]):
MsgBox "You must enter dispute comments for each disputed subcategory."
GoTo Leave
Case IsNull(rs![ComboFieldName]) And Not IsNull(rs![TextBoxFieldName]):
MsgBox "You must state if the rationale is aligned with procedures for each disputed subcategory."
GoTo Leave
Case Else:
'do nothing
End Select
rs.MoveNext
Next idx
Set rs = Nothing
With DoCmd
.Save
.Close
End With
Exit Sub
Leave:
Set rs = Nothing
End Sub
I'm currently working on an Excel application that can get info from my Form worksheet and display it into Display worksheet. So far the data can transfer perfectly, except for one tiny quirk.
The Display worksheet will display data when Execute is clicked.
Here is the screenshot:
Before I execute the Display, the Time field in the Form worksheet is formatted as h:mm AM/PM. However, when I click Execute in Display worksheet, the Time format suddenly changed in the Form Worksheet as seen here:
Furthermore the change in format is also seen in the Display table as well. I tried setting the format to be identical for both worksheets and the result is still the same.
Is it the issue of the SQL1 statement or the coding in general? here is the code sample.
Public Sub QueryWorksheet(szSQL As String, rgStart As Range, wbWorkBook As String, AB As String)
Dim rsData As ADODB.Recordset
Dim szConnect As String
On Error GoTo ErrHandler
If AB = "1st" Then
wbWorkBook = ActiveWorkbook.Sheets("Inner Workings").Range("B9").Text
End If
Application.StatusBar = "Retrieving data ....."
'Set up the connection string to excel - thisworkbook
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & wbWorkBook & ";" & _
"Extended Properties=Excel 8.0;"
Set rsData = New ADODB.Recordset
'Run the query as adCmdText
rsData.Open szSQL, szConnect, adOpenForwardOnly, adLockReadOnly, adCmdText
'Check if data is returned
If Not rsData.EOF Then
'if the recordset contains data put them on the worksheet
rgStart.CopyFromRecordset rsData
Else
End If
'Close connection
rsData.Close
'Clean up and get out
Set rsData = Nothing
Application.StatusBar = False
Exit Sub
ErrHandler:
'an error occured in the SQL-statement
MsgBox "Your query could not be executed, the SQL-statement is incorrect."
Set rsData = Nothing
Application.StatusBar = False
End Sub
Sub process()
Call clear
Call testsql("1st") ' populate 1st Summary
Call testsql("2nd") ' find Date+Time
Call testsql("3rd") ' GET LATEST RECORD
End Sub
Sub testsql(AB As String)
Dim rgPlaceOutput As Range 'first cell for the output of the query
Dim stSQLstring As String 'text of the cell containing the SQL statement
Dim rg As String, SQL As String
If AB = "1st" Then
stSQLstring = ActiveWorkbook.Sheets("Inner Workings").Range("B2").Text
Set rgPlaceOutput = ActiveWorkbook.Sheets("1st Summary").Range("A2")
End If
If AB = "2nd" Then
stSQLstring = ActiveWorkbook.Sheets("Inner Workings").Range("B3").Text
Set rgPlaceOutput = ActiveWorkbook.Sheets("2nd Summary").Range("A2")
End If
If AB = "3rd" Then
stSQLstring = ActiveWorkbook.Sheets("Inner Workings").Range("B4").Text
Set rgPlaceOutput = ActiveWorkbook.Sheets("Final Summary").Range("A5")
End If
QueryWorksheet stSQLstring, rgPlaceOutput, ThisWorkbook.FullName, AB
End Sub
Sub clear()
ActiveWorkbook.Sheets("1st Summary").Range("A2:BR5000").Value = Empty
ActiveWorkbook.Sheets("2nd Summary").Range("A2:BR5000").Value = Empty
ActiveWorkbook.Sheets("Final Summary").Range("A2:BR5000").Value = Empty
End Sub
If anyone can help with this, I greatly appreciate it.
Update:
Apparently, this quirk is larger than I thought. After more testing I found out that the second summary sheet is also affected as well as seen here. . Albeit the lower half at least. The mystery keeps piling up...
I think you have to look at NumberFormat iirc add something like "DD/MM/YYYY" to a Range (columns in your case). I'm on a Mac with Office 365, and although VBA is now in the app, the sort of intellisense is absent so unless you know the Excel Object model by heart it's a royal PITA!
I use MS Access macros and queries to build my application. I use some temporary import files, and need to either run a macro, or some VBA, to test if they exist, and then if they do, to delete them.
My table name is "TempImport1"
I've researched this via Google searches and have some VBA that might work. I have cut/pasted VBA code under a button in the past, and it worked, but not this time. How do I put the code into a module or a click sub button?
Function IsTable(sTblName As String) As Boolean
'does table exists and work ?
'note: finding the name in the TableDefs collection is not enough,
' since the backend might be invalid or missing
On Error GoTo TrapError
Dim x
x = DCount("*", sTblName)
IsTable = True
Exit Function
TrapError:
Debug.Print Now, sTblName, Err.Number, Err.Description
IsTable = False
End Function
First you should check whether the table exists and then you should try to close it, if it exists. Then you should set warnings to False, so it does not ask you whether you are sure that you want to delete the table.
In the example below, you delete Table3. The If Not IsNull is checking whether the table exists:
Option Compare Database
Option Explicit
Public Sub DeleteIfExists()
Dim tableName As String
tableName = "Table3"
If Not IsNull(DLookup("Name", "MSysObjects", "Name='" & tableName & "'")) Then
DoCmd.SetWarnings False
DoCmd.Close acTable, tableName, acSaveYes
DoCmd.DeleteObject acTable = acDefault, tableName
Debug.Print "Table" & tableName & "deleted..."
DoCmd.SetWarnings True
End If
End Sub
Pretty much the code should work.
To delete the TempImport1 table if it exists just use the below function.
Function DeleteTables()
If Not IsNull(DLookup("Name", "MSysObjects", "Name='TempImport1' AND Type = 1")) Then
DoCmd.DeleteObject acTable, "TempImport1"
End If
End Function
Once the function has been created, create a macro, add the action run code then type in DeleteTables() in to the Function Name.
You then have a macro to run to delete the table if it exists.
Checking MSysObjects (used in other answers) misreported a table as existing if it was recently deleted. I found the following test more reliable.
Option Compare Database
Option Explicit
Public Sub DeleteIfExists()
Dim tableName As String
tableName = "Table3"
On Error Resume Next
Set td = db.TableDefs(tableName)
If Err.Number <> 0 Then
DoCmd.SetWarnings False
DoCmd.Close acTable, tableName, acSaveYes
DoCmd.DeleteObject acTable = acDefault, tableName
Debug.Print "Table" & tableName & "deleted..."
DoCmd.SetWarnings True
End If
End Sub
Here is the version I created to get rid of import error tables. The Err. Number must be 0 to actually remove table. TRACE is my internal flag.
Public Function RemoveImportErrorTables(Optional strTableBaseName As String = "rngExportDaily_ImportErrors") As Integer
'Purpose:
' Remove ImportError Tables
'In:
' Tables base Name
'Out:
' number of tables flushed
'History:
' Created 2021-12-06 16:10 Anton Sachs; Last modified 2021-12-06 16:15 Anton Sachs
'
Dim intResult As Integer
Dim strTableName As String
Dim dbCur As Database
Dim tdfTableDef As TableDef
Dim intTableIndex As Integer
On Error GoTo RemoveImportErrorTables_Err
Set dbCur = CurrentDb()
For intTableIndex = 0 To 100
If intTableIndex = 0 Then
strTableName = strTableBaseName
Else
strTableName = strTableBaseName & CStr(intTableIndex)
End If
On Error Resume Next
Set tdfTableDef = dbCur.TableDefs(strTableName)
If Err.Number = 0 Then
DoCmd.SetWarnings False
DoCmd.Close acTable, strTableName, acSaveYes
DoCmd.DeleteObject acTable = acDefault, strTableName
DoCmd.SetWarnings True
intResult = intResult + 1
Else
On Error GoTo RemoveImportErrorTables_Err
Exit For
End If
Next intTableIndex
RemoveImportErrorTables_Exit:
RemoveImportErrorTables = intResult
If Not tdfTableDef Is Nothing Then
Set tdfTableDef = Nothing
End If
If Not dbCur Is Nothing Then
Set dbCur = Nothing
End If
Exit Function
RemoveImportErrorTables_Err:
If TRACE = 0 Then TRACE = GetStandard("Trace")
If TRACE <> False Then
Debug.Print "Error " & Err.Number & " " & Err.Description & " in RemoveImportErrorTables"
Err.Clear
If TRACE = CTR±Stop Then
Stop
Resume Next
End If
Else
Err.Clear
Resume Next
End If
RemoveImportErrorTables_Fail:
intResult = False
GoTo RemoveImportErrorTables_Exit
End Function
Hey guys I need some help. I was tasked with a business intelligence project where the initial step is logging users’ entrance and exit dates and times. So I have three modules:
modCaptureIns and modCaptureOuts; Also, I have modCaptureIns' function RecordIns() running on the AutoExec macro and modCaptureOuts running on when a hidden form named frmCaptureOuts is closed (upon user closing database).
Here is the problem: When a single user opens and closes the database entrance and exit times are logged in tblInsNOuts. As soon as you have more than one user, the second user is changing the SessId variable to a different number, and then the exit times are not recorded. Please give me a hand. Any help will be much appreciated.
CF
`Option Compare Database
Option Explicit
Public SessID As Integer
Public Function RecordIns()
On Error GoTo ErrorHandler
Dim db As Database
Dim rs As Recordset
DoCmd.SetWarnings False
SessID = DFirst("[MaxOfSessionID]", "[qryMaxOfSessionID]") + 1
Set db = CurrentDb
Set rs = db.OpenRecordset("tblInsNOuts")
rs.AddNew
rs.Fields("SessionID") = SessID
rs.Fields("WinID") = GetUser()
rs.Fields("EntryStamp") = Now()
rs.Update
DoCmd.SetWarnings True
rs.Close
Set rs = Nothing
db.Close
ExitSub:
Exit Function
ErrorHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume ExitSub
End Function
Option Compare Database
Option Explicit
Public Function ExitStamp()
On Error GoTo ErrorHandler
Dim db As Database
Dim rs As Recordset
Dim fldEnumerator As Object
Dim fldColumns As Object
Set db = CurrentDb
Set rs = db.OpenRecordset("tblInsNOuts")
Set fldColumns = rs.Fields
DoCmd.SetWarnings False
While Not rs.EOF
For Each fldEnumerator In rs.Fields
If fldEnumerator.Name = "SessionID" Then
If fldEnumerator.Value = SessID Then
rs.Edit
rs.Fields("ExitStamp") = Now()
rs.Update
End If
End If
Next
rs.MoveNext
Wend
DoCmd.SetWarnings True
rs.Close
Set rs = Nothing
db.Close
ExitSub:
Exit Function
ErrorHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume ExitSub
End Function
Option Compare Database
Private Sub Form_Close()
Call ExitStamp
End Sub
`
I went a step further with this. I was able to open another Windows image and therefore a second snapshot of the DB. When I opened both snapshots at the same time it logs the entry times for both, but when close the first one it drops the value of SessID. I realized the snapshot which remains open could no longer access the value of SessID because it's now null. Still need some help guys