On-click event on an unbound control in MS Access - ms-access

I am trying to modify a sample by Roggers here for my project to browse multiple images in MS Access form.
But, I would like to know how I can add an on-click event for the image control to open a details form.
The code behind the form is as follows:
Private Sub P_FillControls()
On Error GoTo ErrTrap
Dim Cnt As Long
Cnt = 1
Do Until (Cnt > BlockSize Or rst.EOF)
P_SetValues Cnt
Cnt = Cnt + 1
rst.MoveNext
Loop
If Cnt <= BlockSize Then
For Cnt = Cnt To BlockSize
P_SetNulls Cnt
Next
End If
ExitPoint:
On Error GoTo 0
Exit Sub
ErrTrap:
MsgBox Err.Number & " - " & Err.Description
Resume ExitPoint
End Sub
Private Sub P_SetValues(Cnt As Long)
On Error GoTo ErrTrap
If RecCount > 0 Then
Me("Rn_" & Format(Cnt, "00")).Caption = (rst.AbsolutePosition + 1)
Else
Me("Rn_" & Format(Cnt, "00")).Caption = ""
End If
Me("Lb_" & Format(Cnt, "00")).Caption = Nz(rst.Fields("ImageName"), "")
Me("Im_" & Format(Cnt, "00")).Picture = Nz(rst.Fields("ImageFile"), "")
Me("ID_" & Format(Cnt, "00")) = rst.Fields("ImageFile")
' Note - For no caption, dot is used in lieu of
' zero length string, so as to prevent the
' label from disappearing
ExitPoint:
On Error GoTo 0
Exit Sub
ErrTrap:
MsgBox Err.Number & " - " & Err.Description
Resume ExitPoint
End Sub
Private Sub P_SetNulls(Cnt As Long)
On Error GoTo ErrTrap
Me("Rn_" & Format(Cnt, "00")).Caption = "."
Me("Lb_" & Format(Cnt, "00")).Caption = "."
Me("Im_" & Format(Cnt, "00")).Picture = "."
Me("ID_" & Format(Cnt, "00")) = Null
' Note - For no caption, dot is used in lieu of
' zero length string, so as to prevent the
' label from disappearing
ExitPoint:
On Error GoTo 0
Exit Sub
ErrTrap:
MsgBox Err.Number & " - " & Err.Description
Resume ExitPoint
End Sub
Public Sub P_Initialize()
On Error Resume Next
RecCount = 0 ' Default
Me.LbNoImage.Visible = False
' Remove any existing instance of the recordset
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
End If
' This recordset will finally get closed in form's
' close event.
Set rst = CurrentDb.OpenRecordset("Q_ImageNormalSort")
' Set rst = CurrentDb.OpenRecordset("Q_Dynamic_Query")
If rst.EOF And rst.BOF Then
' There are no records
P_FillControls
Me.LbNoImage.Visible = True
P_SetStatusNavBtns
Me.CmdAdd.SetFocus
Exit Sub
End If
rst.MoveLast
RecCount = rst.RecordCount
LastID = rst.Fields("ImageFile")
rst.MoveFirst
FirstID = rst.Fields("ImageFile")
' First Load (signified by step size argument = 0)
P_Next 0
Me.LbRecMsg.Caption = "Of " & RecCount
On Error GoTo 0
End Sub
In the sample, "Im_" is the control that holds the image on the form.
I will appreciate your help.
Joseph

Put the following Sub in your code somewhere at the bottom:
Function OpenMyForm(strFormName As String)
DoCmd.OpenForm strFormName
End Function
Stick this in your code below where you set the image:
Me("Im_" & Format(Cnt, "00")).OnClick = "=OpenMyForm('F_Details')"

Related

Duplicate records when running a DAO recordset

I developed an access database to log jobs throughout a production process. Every record has an order, machine, start time, end time among other characteristics of the job. When an order is logged, it is saved in the database along with the machine name, start time and job status (running or idle). When the order is completed, the record is searched using a recordset and "end time" is saved. If the machine is not being utilized, like between shifts, the machine should have an "idle" status.
The purpose of OpenRecMassUpdate is to add an 'end time' to all the incomplete records (those with an order, start time but without end time). This code is used at the end of shift so that all the records could be closed with one click.
After executing this subroutine, the machines that were assigned to an order are now without a status. As a result, I needed another subroutine to add "idle" statuses to all these machines. That is the purpose of MassIdleUpdate. It creates an idle record for every machine that was previously used and status closed using OpenRecMassUpdate.
The problem I am facing is that MassIdleUpdate creates multiple records at random times. When I run analysis on the database, I found some records that were created 3, 4 or more times.
Option Compare Database
Dim dbsn As DAO.Database
Dim rstn As DAO.Recordset
Dim SQLqueryn As String
Dim recordcount As Integer
Dim tempstat As String
Dim stat1 As Integer
Public Sub OpenRecMassUpdate()
On Error GoTo ErrorHandler
recordcount = 1
tempstat = "Idle"
stat1 = 0
Set dbsn = CurrentDb
SQLqueryn = "SELECT * FROM kettleLog WHERE KettleStatus <> """ & tempstat & _
""" And KettleLogic = " & stat1
Set rstn = dbsn.OpenRecordset(SQLqueryn)
With rstn
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
While (Not .EOF)
.Edit
.Fields("KettleFinish") = Now()
.Fields("KettleLogic") = -1
.Fields("EndOfShift") = 1
.Update
.MoveNext
recordcount = recordcount + 1
Wend
MsgBox recordcount - 1 & " records were updated as a result of the end of the shift"
recordcount = 1
Else
End If
.Close
End With
dbsn.Close
ExitSub:
Set dbsn = Nothing
Set rstn = Nothing
Exit Sub
ErrorHandler:
MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
Resume ExitSub
End Sub
Public Sub MassIdleUpdate()
Dim tempKettle As String
On Error GoTo ErrorHandler
Set dbsn = CurrentDb
SQLqueryn = "SELECT * FROM kettleLog WHERE EndOfShift = 1"
Set rstn = dbsn.OpenRecordset(SQLqueryn)
With rstn
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
For i = 1 To FindRecordCount(SQLqueryn)
tempKettle = .Fields("Kettle")
.Edit
.Fields("EndOfShift") = 3
.Update
.AddNew
.Fields("Kettle") = tempKettle
.Fields("KettleStatus") = "Idle"
.Fields("WorkOrder") = 0
.Fields("KettleStart") = Now()
.Fields("KettleLogic") = 0
.Fields("EndOfShift") = 2
.Update
.MoveNext
Next
End If
.Close
End With
tempKetlle = ""
dbsn.Close
i = 1
ExitSub:
Set dbsn = Nothing
Set rstn = Nothing
Exit Sub
ErrorHandler:
MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
Resume ExitSub
End Sub
Instead of looping through all your records counting them and setting the values individually, do it all in one shot. An RDBMS (even Access) is designed for this kind of bulk update.
Public Sub OpenRecMassUpdate()
On Error GoTo ErrorHandler
Dim tempStat As String
tempStat = "Idle"
Dim stat1 As Long
stat1 = 0
Set dbsn = CurrentDb
Dim timeStamp As Date
timeStamp = Now()
SQLqueryn = "UPDATE KettleLog " & _
" SET KettleFinish = #" & timeStamp & "#, " & _
" KettleLogic = -1, " & _
" EndOfShift = 1 " & _
" WHERE KettleStatus <> """ & tempStat & """" & _
" AND KettleLogic = 0"
Set rstn = dbsn.OpenRecordset(SQLqueryn)
rstn.Close
SQLqueryn = "SELECT Count(*) " & _
" FROM KettleFinish " & _
" WHERE KettleFinish = #" & timeStamp & #", " & _
" AND KettleLogic = -1 " & _
" AND EndOfShift = 1"
Set rstn = dbsn.OpenRecordset(SQLqueryn)
If Not rstn.BOF And Not rstn.EOF Then
rstn.MoveLast
Dim recordcount As Long
recordcount = rstn.recordcount
End If
MsgBox recordcount & " records were updated as a result of the end of the shift"
rstn.Close
dbsn.Close
ExitSub:
Exit Sub
ErrorHandler:
MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
Resume ExitSub
End Sub
Note: I'm used to ADO syntax, not DAO, so there might be a minor tweak or two needed, but this should get you started
This will do what your OpenRecMassUpdate() procedure was doing in precisely 2 SQL queries instead of that time consuming loop.
You can also do the same thing to Sub MassIdleUpdate().
As a matter of fact, with a little creativity, you could probably combine the two of them into one, though keeping them separate reduces complexity, improves readability and, thus, future maintainability.
Thanks to #Freeman who guided me in the right direction. Here's my solution to the issue I had. The code has been tested in my sandbox using different scenarios and it works.
Public Sub OpenRecMassUpdate1()
On Error GoTo ErrorHandler
Dim tempStat As String
tempStat = "Idle"
Dim stat1 As Long
stat1 = 0
Set dbsn = CurrentDb
Dim timeStamp As Date
timeStamp = Now()
SQLqueryn = "UPDATE KettleLog " & _
" SET KettleFinish = #" & timeStamp & "#, " & _
" KettleLogic = -1, " & _
" EndOfShift = 1 " & _
" WHERE KettleStatus <> """ & tempStat & """" & _
" AND KettleLogic = 0"
dbsn.Execute SQLqueryn, dbFailOnError
SQLqueryn = "SELECT Count(*) " & _
"AS RecCount " & _
" FROM KettleLog " & _
" WHERE KettleLogic = -1 " & _
" AND EndOfShift = 1"
Set rstn = dbsn.OpenRecordset(SQLqueryn)
If Not rstn.BOF And Not rstn.EOF Then
Dim recordcount As Long
recordcount = rstn![RecCount]
End If
MsgBox recordcount & " records were updated as a result of the end of the shift"
rstn.Close
dbsn.Close
ExitSub:
Exit Sub
ErrorHandler:
MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
Resume ExitSub
End Sub
Public Sub MassIdleUpdate1()
On Error GoTo ErrorHandler
Dim TempKettle As String
Set dbsn = CurrentDb
SQLqueryn = "SELECT * " & _
" FROM KettleLog " & _
" WHERE EndOfShift = 1"
Set rstn = dbsn.OpenRecordset(SQLqueryn)
rstn.MoveLast
Dim rcrdcnt As Long
rcrdcnt = rstn.recordcount
ReDim machs(rcrdcnt) As String
'MsgBox rcrdcnt
rstn.MoveFirst
If Not rstn.BOF And Not rstn.EOF Then
For i = 0 To rcrdcnt - 1
machs(i) = rstn.Fields("Kettle")
rstn.MoveNext
Next
End If
SQLqueryn = "UPDATE KettleLog " & _
" SET EndOfShift = 3 " & _
" WHERE EndOfShift = 1 "
dbsn.Execute SQLqueryn, dbFailOnError
For j = 0 To rcrdcnt
SQLqueryn = "INSERT INTO KettleLog (Kettle, KettleStatus, WorkOrder, KettleStart,
KettleLogic, EndOfShift) " & _
" VALUES ( '" & machs(j) & "' , 'Idle', '0', #" & Now() & "#, '0', '2')"
MsgBox SQLqueryn
dbsn.Execute SQLqueryn, dbFailOnError
machs(j) = ""
Next
rstn.Close
dbsn.Close
ExitSub:
Exit Sub
ErrorHandler:
MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
Resume ExitSub
End Sub

Subform calulation error when pasting multiple records in subform

I do a calculation on all three Events on a subform to update the main form:
Private Sub Form_AfterDelConfirm(Status As Integer)
Me.Parent.UpdateStunden
End Sub
Private Sub Form_AfterInsert()
Me.Parent.UpdateStunden
End Sub
Private Sub Form_AfterUpdate()
Me.Parent.UpdateStunden
End Sub
Public Sub UpdateStunden(Optional BeforeUpdateEvent As Boolean = False)
On Error GoTo ErrorHandler
Dim rst As Recordset
Dim sql As String
Dim NewStunden As Variant
If Me.NewRecord Then Exit Sub
sql = _
"SELECT Sum(Stunden) AS SumStunden " & _
"FROM Tätigkeiten " & _
"WHERE Tätigkeitsdatum = #" & Format(Me!Tätigkeitsdatum, "yyyy-mm-dd") & "#;"
Set rst = CurrentDb().OpenRecordset(sql, dbOpenSnapshot)
If Not rst.EOF Or Not rst.BOF Then
NewStunden = rst!SumStunden
If Nz(NewStunden) <> Nz(Me.Stunden) Or IsNull(Me.Stunden) Then
Me.Stunden = NewStunden
End If
End If
ExitPoint:
On Error Resume Next
If Me.Dirty And Not BeforeUpdateEvent Then Me.Dirty = False
rst.Close
Set rst = Nothing
Exit Sub
ErrorHandler:
Select Case Err
Case Else: LogNTEvent Now & "Error: " & Err & ": " & Err.Description & ": UpdateStunden", EVENTLOG_ERROR_TYPE, 1000, "Error: " & Err.Number
End Select
Resume ExitPoint
End Sub
This normally works fine.
But there is a bug if I copy and paste more than one record into the subform. When I copy and paste multiple records from one subform to the same subform but on another main-form record the calculation is wrong.
This should work as Standard because I use it everywhere.
We Need an After Paste Event!
Does anyone know how to do this?
Regards Richard
Just set the main form value to null from the subform:
Private Sub Form_AfterDelConfirm(Status As Integer)
Me.Parent.Stunden = Null
End Sub
Private Sub Form_AfterInsert()
Me.Parent.Stunden = Null
End Sub
Private Sub Form_AfterUpdate()
Me.Parent.Stunden = Null
End Sub
Then use the timer:
Private Sub Form_Timer()
If IsNull(Me.Stunden) Then UpdateStunden
End Sub
Private Sub Stunden_AfterUpdate()
Me.Dirty = False
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
UpdateStunden True
End Sub
Public Sub UpdateStunden(Optional BeforeUpdateEvent As Boolean = False)
On Error GoTo ErrorHandler
Dim rst As Recordset
Dim sql As String
Dim NewStunden As Variant
If Me.NewRecord Then Exit Sub
sql = _
"SELECT Sum(Stunden) AS SumStunden " & _
"FROM Tätigkeiten " & _
"WHERE Tätigkeitsdatum = #" & Format(Me!Tätigkeitsdatum, "yyyy-mm-dd") & "#;"
Set rst = CurrentDb().OpenRecordset(sql, dbOpenSnapshot)
If Not rst.EOF Or Not rst.BOF Then
NewStunden = rst!SumStunden
If Nz(NewStunden) <> Nz(Me.Stunden) Or IsNull(Me.Stunden) Then
Me.Stunden = NewStunden
End If
End If
ExitPoint:
On Error Resume Next
If Me.Dirty And Not BeforeUpdateEvent Then Me.Dirty = False
rst.Close
Set rst = Nothing
Exit Sub
ErrorHandler:
Select Case Err
Case Else: LogNTEvent Now & "Error: " & Err & ": " & Err.Description & ": UpdateStunden", EVENTLOG_ERROR_TYPE, 1000, "Error: " & Err.Number
End Select
Resume ExitPoint
End Sub
Just set the Control-Source of the Textbox-Control on the main form to this:
=DomSumme("Stunden";"Tätigkeiten";"Tätigkeitsdatum = #" & Format([Tätigkeitsdatum];"jjjj-mm-tt") & "#")
And then requery after all three Events:
Private Sub Form_AfterDelConfirm(Status As Integer)
Me.Parent!Test.Requery
End Sub
Private Sub Form_AfterInsert()
Me.Parent!Test.Requery
End Sub
Private Sub Form_AfterUpdate()
Me.Parent!Test.Requery
End Sub
N.B. German Office 2010

Error when trying to compile

I'm getting a compile error:
Sub or function not defined(error area in bold)
Option Compare Database
Option Explicit
Private Sub cboDates_AfterUpdate()
On Error Resume Next
Dim strInterval As String
Dim dblValue As Double
Dim datStartDate As Date
Dim datEndDate As Date
Dim WeekdayStsrt As Integer
WeekdayStsrt = 1 'Start day of week - 1=Sunday, 2=Monday, 3=Tuesday...
'Sets Start and End Date textboxes based on combobox selection
strInterval = Me.cboDates.Column(1)
dblValue = Me.cboDates.Column(2)
Select Case strInterval
Case "d"
datStartDate = Date
datEndDate = Date
Case "ww"
datStartDate = Date - Weekday(Date) + WeekdayStsrt
datEndDate = datStartDate + 6
Case "m"
datStartDate = DateSerial(Year(Date), Month(Date) + dblValue, 1)
datEndDate = DateSerial(Year(Date), Month(Date) + dblValue + 1, 0)
dblValue = 0
Case "yyyy"
datStartDate = DateSerial(Year(Date), 1, 1)
datEndDate = DateSerial(Year(Date), 12, 31)
Case "YTD"
datStartDate = DateSerial(Year(Date), 1, 1)
datEndDate = Date
strInterval = "yyyy"
Case "All"
datStartDate = DateSerial(2000, 1, 1) 'Earliest Date of available data in system
datEndDate = DateSerial(Year(Date), 12, 31)
strInterval = "d"
End Select
Me.txtStartDate = DateAdd(strInterval, dblValue, datStartDate)
Me.txtEndDate = DateAdd(strInterval, dblValue, datEndDate)
End Sub
Private Sub cboReportGroup_AfterUpdate()
On Error GoTo Err_Trap
'Filter listbox based on Report Group combobox selection.
Dim SQL As String
Me.lstReport = Null
SQL = Me.lstReport.Tag
If Not Me.cboReportGroup = "(All)" Then
SQL = SQL & " WHERE ReportGroup='" & Me.cboReportGroup & "'"
End If
SQL = SQL & " ORDER BY tsysReports.ReportTitle;"
Me.lstReport.RowSource = SQL
Err_Trap_Exit:
Exit Sub
Err_Trap:
MsgBox Err.Description
Resume Err_Trap_Exit
End Sub
Private Sub cmdEndDate_Click()
On Error Resume Next
'Launch Calendar Control
DateCheck_MEI Me.txtEndDate
Me.cboDates = Null
End Sub
Private Sub cmdExport_Click()
On Error GoTo Err_Trap
Dim SQL As String
Echo False
Call cmdOpen_Click 'execute the button that opens the report for print preview
SQLEdit_MEI "ArrivalTimingTableQuery", Application.Reports(Me.lstReport).RecordSource
If Application.Reports(Me.lstReport).Filter = "" Then
SQL = "SELECT * FROM ArrivalTimingTableQuery "
Else
SQL = "SELECT * FROM ArrivalTimingTableQuery WHERE " & Application.Reports(Me.lstReport).Filter
End If
SQLEdit_MEI "qryTempExport", SQL
DoCmd.OutputTo acOutputQuery, "qryTempExport", acFormatXLS, CurrentProject.Path & "\temp.xls", True
DoCmd.Close acReport, Me.lstReport, acSaveNo
Echo True
Err_Trap_Exit:
Exit Sub
Err_Trap:
Echo True
MsgBox Err.Description
Resume Err_Trap_Exit
End Sub
Private Sub cmdOpen_Click()
On Error GoTo Err_Trap
Dim strCriteria As String
If Me.txtEndDate < Me.txtStartDate Then
MsgBox "End Date cannot be prior to Start Date."
Exit Sub
End If
If IsNull(Me.lstReport) Then
MsgBox "Please select a report"
Exit Sub
End If
If Not Me.lstReport.Column(2) = "" Then
strCriteria = Me.cboField & " Between #" & Me.txtStartDate & "# And #" & Me.txtEndDate & "#"
End If
DoCmd.OpenReport Me.lstReport, acViewReport, , strCriteria
Err_Trap_Exit:
Exit Sub
Err_Trap:
MsgBox Err.Description
Resume Err_Trap_Exit
End Sub
Private Sub cmdStartDate_Click()
On Error Resume Next
'Launch Calendar Control
DateCheck_MEI Me.txtStartDate
Me.cboDates = Null
End Sub
Private Sub Form_Load()
Call cboReportGroup_AfterUpdate
End Sub
Private Sub lstReport_Click()
On Error Resume Next
Me.lblDescription.Caption = "Report Description: " & Me.lstReport.Column(3)
Me.cboField.RowSource = Me.lstReport.Column(2) 'Set to values of DateCriteria field of table tsysReports
Me.cboField = Me.cboField.ItemData(0) 'Select 1st item in combobox
'Hide Report Criteria Section if no Date Filter for selected report
If Me.lstReport.Column(2) = "" Then
Me.box1.Visible = True
Else
Me.box1.Visible = False
End If
End Sub
Private Sub lstReport_DblClick(Cancel As Integer)
Call cmdOpen_Click
End Sub
From what you've posted, and ignoring what may be wrong inside of your sub,
the fix would be to end the sub:
Private Sub cmdStartDate_Click()
'Do stuff
End Sub 'This is the part you are missing

Audit Trail for unbound forms/textboxes

I have been searching for days for ways on how to implement an audit trail in my access 2010 database. There are plenty of solutions out there that work great when the form is bound, but I have several forms that are unbound and perform certain critical functions I wish to have an audit trail on (they are unbound due to having to edit different tables depending on user input, functions performed through VB and SQL scripting, so binding them to a table would not work). But there seems to be no easy solutions on this type of auditing without doing weeks and weeks worth of custom coding. Does anyone have any ideas on how to do this? Is there a way to audit all activity without having to bind a form? Can't I just have code that monitors a table's changes without having to go though code on the back side of the forms?
I have recently done this!
Each form has code to write changes to a table.
The Audit Trail gets a bit tricky when you lose Screen.ActiveForm.Controls as the reference - which happens if you use a Navigation Form.
It is also using Sharepoint lists so I found that none of the published methods were available.
I (often) use a form in the middle as a display layer and I find it has to fire the Form_Load code in the next forms down the line as well.
Once they are open they need to be self sustaining.
Module Variable;
Dim Deleted() As Variant
Private Sub Form_BeforeUpdate(Cancel As Integer)
'Audit Trail - New Record, Edit Record
Dim rst As Recordset
Dim ctl As Control
Dim strSql As String
Dim strTbl As String
Dim strSub As String
strSub = Me.Caption & " - BeforeUpdate"
If TempVars.Item("AppErrOn") Then
On Error Resume Next 'On Error GoTo Err_Handler
Else
On Error GoTo 0
End If
strTbl = "tbl" & TrimL(Me.Caption, 6)
strSql = "SELECT * FROM tblzzAuditTrail WHERE DateTimeMS = #" & GetTimeUTC & "#;"
Set rst = dbLocal.OpenRecordset(strSql)
For Each ctl In Me.Detail.Controls
If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then
If ctl.Name <> "DateUpdated" Then
If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
If Me.NewRecord Then
With rst
.AddNew
!DateTimeMS = GetTimeUTC()
!UserID = TempVars.Item("CurrentUserID")
!ClientID = TempVars.Item("frmClientOpenID")
!RecordID = Me.Text26
!ActionID = 1
!TableName = strTbl
!FieldName = ctl.ControlSource
!NewValue = ctl.Value
.Update
End With
Else
With rst
.AddNew
!DateTimeMS = GetTimeUTC()
!UserID = TempVars.Item("CurrentUserID")
!ClientID = TempVars.Item("frmClientOpenID")
!RecordID = Me.Text26
!ActionID = 2
!TableName = strTbl
!FieldName = ctl.ControlSource
!NewValue = ctl.Value
!OldValue = ctl.OldValue
.Update
End With
End If
End If
End If
End If
Next ctl
rst.Close
Set rst = Nothing
Exit Sub
Err_Handler:
Select Case Err.Number
Case 3265
Resume Next 'Item not found in recordset
Case Else
'Unexpected Error
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: " & strSub & vbCrLf & "Error Description: " & _
Err.Description, vbExclamation, "An Error has Occured!"
End Select
rst.Close
Set rst = Nothing
End Sub
Private Sub Form_Delete(Cancel As Integer)
Dim ctl As Control
Dim i As Integer
Dim strTbl As String
strTbl = "tbl" & TrimL(Me.Caption, 6)
ReDim Deleted(3, 1)
For Each ctl In Me.Detail.Controls
If ctl.ControlType <> acLabel Then
' Debug.Print .Name
If ctl.Name <> "State" And ctl.Name <> "Pcode" Then
If Nz(ctl.Value) <> "" Then
Deleted(0, i) = ctl.ControlSource
Deleted(1, i) = ctl.Value
Deleted(2, i) = Me.Text26
' Debug.Print Deleted(0, i) & ", " & Deleted(1, i)
i = i + 1
ReDim Preserve Deleted(3, i)
End If
End If
End If
Next ctl
End Sub
Private Sub Form_AfterDelConfirm(Status As Integer)
Dim rst As Recordset
Dim ctl As Control
Dim strSql As String
Dim strTbl As String
Dim i As Integer
Dim strSub As String
strSub = Me.Caption & " - AfterDelConfirm"
If TempVars.Item("AppErrOn") Then
On Error Resume Next 'On Error GoTo Err_Handler
Else
On Error GoTo 0
End If
strTbl = "tbl" & TrimL(Me.Caption, 6)
strSql = "SELECT * FROM tblzzAuditTrail WHERE DateTimeMS = #" & GetTimeUTC() & "#;"
Set rst = dbLocal.OpenRecordset(strSql)
'Audit Trail - Deleted Record
If Status = acDeleteOK Then
For i = 0 To UBound(Deleted, 2) - 1
With rst
.AddNew
!DateTimeMS = GetTimeUTC()
!UserID = TempVars.Item("CurrentUserID")
!ClientID = TempVars.Item("frmClientOpenID")
!RecordID = Deleted(2, i)
!ActionID = 3
!TableName = strTbl
!FieldName = Deleted(0, i)
!NewValue = Deleted(1, i)
.Update
End With
Next i
End If
rst.Close
Set rst = Nothing
Exit Sub
Err_Handler:
Select Case Err.Number
Case 3265
Resume Next 'Item not found in recordset
Case Else
'Unexpected Error
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: " & strSub & vbCrLf & "Error Description: " & _
Err.Description, vbExclamation, "An Error has Occured!"
End Select
rst.Close
Set rst = Nothing
End Sub

vb 6.0 can anyone help me with my code?

Im working with my project inventory system i want to display the filtered dates in my books table in the mysql in my listview1 using 2 DTPicker and make a report for it. Im having an error in my query in the classmodule idk if its only the query and im really confused im a begginer in vb 6.0...please in need your help guys.
Im using 2 tables namely books and supplier.
MY CODE IN THE 'CLASS MODULE':
Sub DisplayList(ListView1 As ListView, DateFrom As Date, DateTo As Date)
Dim lstItem As ListItem, a As Integer
Dim rs As New ADODB.Recordset
Dim sql As String
If rs.State = adStateOpen Then rs.Close
sql = " SELECT supplier.category,books.title,books.dataAcquired,books.amount,books.quantity,books.accesionno,books.conditions" & _
" From supplier INNER JOIN books" & _
" ON supplier.code=books.code" & _
" WHERE (((books.dataAcquired)>=#" & DateFrom & "#) and ((books.dataAcquired) <=#" & DateTo & "#))" & _
" GROUP BY supplier.category,books.title,books.dataAcquired,books.amount,books.quantity,books.accesionno,books.conditions" & _
" ORDER BY books.dataAcquired DESC;"
rs.Open sql, cnn
ListView1.ListItems.Clear
Do While Not rs.EOF
a = a + 1
Set lstItem = ListView1.ListItems.Add(, , a, 1, 1)
lstItem.SubItems(1) = rs(0).Value
lstItem.SubItems(2) = rs(1).Value
lstItem.SubItems(3) = rs(2).Value
lstItem.SubItems(4) = rs(3).Value
lstItem.SubItems(5) = rs(4).Value
lstItem.SubItems(6) = rs(5).Value
lstItem.SubItems(7) = rs(6).Value
rs.MoveNext
Loop
End Sub
MY CODE IN MY FORM:
Private Sub Show_Click()
clsData.DisplayList ListView1, DTPicker1.Value, DTPicker2.Value
lblCount.Caption = ListView1.ListItems.Count
End Sub
Private Sub Form_Load()
DTPicker1.Value = Date
DTPicker2.Value = Date
End Sub
Private Sub Form_Activate()
clsData.DisplayList ListView1, DTPicker1.Value, DTPicker2.Value
lblCount.Caption = ListView1.ListItems.Count
End Sub
Change # by '
format date how yyyy-MM-dd or yyyyMMdd
sql = " SELECT supplier.category,books.title,books.dataAcquired,books.amount,books.quantity,books.accesionno,books.conditions" & _
" From supplier INNER JOIN books" & _
" ON supplier.code=books.code" & _
" WHERE (((books.dataAcquired)>='" & format(DateFrom,"yyyy-MM-dd") & "') and ((books.dataAcquired) <='" & format(DateTo,"yyyy-MM-dd") & "'))" & _
" GROUP BY supplier.category,books.title,books.dataAcquired,books.amount,books.quantity,books.accesionno,books.conditions" & _
" ORDER BY books.dataAcquired DESC;"
change loop while added validations for recordset emptys, some how
if RecordsetIsClosed(rs) then exit sub
While Not RecordSetIsEmpty(rs)
a = a + 1
Set lstItem = ListView1.ListItems.Add(, , a, 1, 1)
lstItem.SubItems(1) = rs(0).Value
lstItem.SubItems(2) = rs(1).Value
lstItem.SubItems(3) = rs(2).Value
lstItem.SubItems(4) = rs(3).Value
lstItem.SubItems(5) = rs(4).Value
lstItem.SubItems(6) = rs(5).Value
lstItem.SubItems(7) = rs(6).Value
rs.MoveNext
wend
Public Function RecordSetIsEmpty(ByRef rs As ADODB.Recordset) As Boolean
' On Local Error GoTo RecordSetIsEmpty_Error
' RecordSetIsEmpty = True
' If rs Is Nothing Then
' RecordSetIsEmpty = True
' Exit Function
' End If
' If RecordsetIsClosed(rs) = True Then
' RecordSetIsEmpty = True
' Exit Function
' End If
RecordSetIsEmpty = (rs.BOF = True And rs.EOF = True)
' RecordSetIsEmpty_Done:
' Exit Function
' RecordSetIsEmpty_Error:
' Resume RecordSetIsEmpty_Done
End Function
Public Function RecordsetIsClosed(ByRef rs As ADODB.Recordset) As Boolean
On Local Error GoTo RecordsetIsClosed_Error
RecordsetIsClosed = True
If rs Is Nothing Then
RecordsetIsClosed = True
End If
If rs.State <> adStateClosed Then
RecordsetIsClosed = False
End If
RecordsetIsClosed_Done:
Exit Function
RecordsetIsClosed_Error:
Resume RecordsetIsClosed_Done
End Function
Dont forget to open the database connection
updated thanks Mark Bertenshaw
RecordSetIsEmpty is use for problems when do movenext.. well i remember
RecordsetIsClosed is use because in some cases and databases managers return not recordset or the recordset is not correct initialized
for example access is necessary use movefist before do movenext or read values