Audit Track a form - ms-access

I am setting up a Audit Tracking system for the forms in my database. I am following the example from Susan Harkins Here
My code works for my form customers which is based off the customers table. Here is my code:
Const cDQ As String = """"
Sub AuditTrail(frm As Form, recordid As Control)
'Track changes to data.
'recordid identifies the pk field's corresponding
'control in frm, in order to id record.
Dim ctl As Control
Dim varBefore As Variant
Dim varAfter As Variant
Dim strControlName As String
Dim strSQL As String
On Error GoTo ErrHandler
'Get changed values.
For Each ctl In frm.Controls
With ctl
'Avoid labels and other controls with Value property.
If .ControlType = acTextBox Then
If .Value <> .OldValue Then
MsgBox "Step 1"
varBefore = .OldValue
varAfter = .Value
strControlName = .Name
'Build INSERT INTO statement.
strSQL = "INSERT INTO " _
& "Audit (EditDate, User, RecordID, SourceTable, " _
& " SourceField, BeforeValue, AfterValue) " _
& "VALUES (Now()," _
& cDQ & Environ("username") & cDQ & ", " _
& cDQ & recordid.Value & cDQ & ", " _
& cDQ & frm.RecordSource & cDQ & ", " _
& cDQ & .Name & cDQ & ", " _
& cDQ & varBefore & cDQ & ", " _
& cDQ & varAfter & cDQ & ")"
'View evaluated statement in Immediate window.
Debug.Print strSQL
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
End If
End If
End With
Next
Set ctl = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description & vbNewLine _
& Err.Number, vbOKOnly, "Error"
End Sub
However, when I try to change data in my subform within the form I get an error "Operation is not supported for this type of object". I can see the error is occuring here:
If .Value <> .OldValue Then
My subform is based off of a query which is based off of three tables
I'm trying to change a customer price under Customer Products and keep a log of those changes. Is there something I'm missing or a work around.
Thank you for the help!

Temporarily disable your error handler like this:
'On Error GoTo ErrHandler
When you get the error notice about "operation not supported", choose Debug from the error dialog. That will allow you to find out more information about the current text box control which is triggering the error. Try the following statements in the Immediate window:
? ctl.Name
? ctl.ControlSource
? ctl.Enabled
? ctl.Locked
? ctl.Value
At least ctl.Name will identify which text box is triggering the error.
After examining the db, I'll suggest a function (IsOldValueAvailable) to indicate whether .OldValue is available for the current control. With that function, the AuditTrail procedure works after this change:
'If .ControlType = acTextBox Then
If IsOldValueAvailable(ctl) = True Then
And the function. It may still need more work, but I didn't spot any problems in my testing.
Public Function IsOldValueAvailable(ByRef ctl As Control) As Boolean
Dim blnReturn As Boolean
Dim strPrompt As String
Dim varOldValue As Variant
On Error GoTo ErrorHandler
Select Case ctl.ControlType
Case acTextBox
varOldValue = ctl.OldValue
blnReturn = True
Case Else
' ignore other control types; return False
blnReturn = False
End Select
ExitHere:
On Error GoTo 0
IsOldValueAvailable = blnReturn
Exit Function
ErrorHandler:
Select Case Err.Number
Case 3251 ' Operation is not supported for this type of object.
' pass
Case Else
strPrompt = "Error " & Err.Number & " (" & Err.Description _
& ") in procedure IsOldValueAvailable"
MsgBox strPrompt, vbCritical, "IsOldValueAvailable Function Error"
End Select
blnReturn = False
Resume ExitHere
End Function

Related

How to compare data types of 2 tables in MS Access

Is there a way wherein I will be able to compare data types of 2 tables in MS Access? I have one table with 66 columns with specified names (Like ID, Name, ETc...) and another table that will be autogenerated based on an extract with the same number of columns but the field names default (F1, F2, F3, ... F66) so would like to check if there is a way in access that I can compare the data types of 66 columns from both tables? Thanks Much! :D
You can use some VBA to loop the Fields collection of each table. Something like this should get you started:
Sub sCompareTables(strTable1 As String, strTable2 As String)
On Error GoTo E_Handle
Dim db As DAO.Database
Dim tdf1 As DAO.TableDef
Dim tdf2 As DAO.TableDef
Dim lngLoop1 As Long
Set db = CurrentDb
Set tdf1 = db.TableDefs(strTable1)
Set tdf2 = db.TableDefs(strTable2)
If tdf1.Fields.Count = tdf2.Fields.Count Then
For lngLoop1 = 0 To tdf1.Fields.Count - 1
If tdf1.Fields(lngLoop1).Type = tdf2.Fields(lngLoop1).Type Then
Debug.Print "Match: " & tdf1.Fields(lngLoop1).name & vbTab & tdf2.Fields(lngLoop1).name & vbTab & fDatatype(tdf1.Fields(lngLoop1).Type)
Else
Debug.Print "No Match: " & tdf1.Fields(lngLoop1).name & vbTab & tdf2.Fields(lngLoop1).name & vbTab & fDatatype(tdf1.Fields(lngLoop1).Type) & "|" & fDatatype(tdf2.Fields(lngLoop1).Type)
End If
Next lngLoop1
Else
Debug.Print "Field counts do not match"
End If
sExit:
On Error Resume Next
Set tdf1 = Nothing
Set tdf2 = Nothing
Set db = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sCompareTables", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Function fDatatype(lngDatatype As Long) As String
On Error GoTo E_Handle
Select Case lngDatatype
Case 4
fDatatype = "Long"
Case 8
fDatatype = "Date"
Case 10
fDatatype = "Text"
Case 12
fDatatype = "Memo"
Case Else
fDatatype = "Unknown"
End Select
fExit:
On Error Resume Next
Exit Function
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "fDatatype", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume fExit
End Function
The function fDatatype that I've created does not list all of the available datatypes that are available - you can see a full list by pressing F2 to bring up the Object Browser, and searching for something like dbText to see all members of the DAO.DataTypeEnum class.

Searching function for textbox and letting my function still run when there are none entries in for the textbox and listbox

All I really need to know is how to make it where I can make selections in multiple multi-select listboxes, but leave any number of them blank and still have the macro/query work without having to put in an error message about it.
This also includes doing the same with the textboxes. The textboxes would function the same as the listboxes where they would search for anything in a data table to matches what I am looking for in the records and display what I am looking for in a table.
Here is my code
Private Sub Command62_Click()
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim varItem As Variant
Dim District As String
Dim Circumstance As String
Dim Location As String
Dim Method As String
Dim Point As String
Dim Rank As String
Dim strSQL As String
Set db = CurrentDb()
Set qdf = db.QueryDefs("qryMultiselect")
For Each varItem In Me!District.ItemsSelected
District = District & ",'" & Me!District.ItemData(varItem) & "'"
Next varItem
If Len(District) = 0 Then
MsgBox "You did not select anything in the Distrcit field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
District = Right(District, Len(District) - 1)
For Each varItem In Me!Circumstance.ItemsSelected
Circumstance = Circumstance & ",'" & Me!Circumstance.ItemData(varItem) &
"'"
Next varItem
If Len(Circumstance) = 0 Then
MsgBox "You did not select anything in the Circumstance field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
Circumstance = Right(Circumstance, Len(Circumstance) - 1)
For Each varItem In Me!Location.ItemsSelected
Location = Location & ",'" & Me!Location.ItemData(varItem) & "'"
Next varItem
If Len(Location) = 0 Then
MsgBox "You did not select anything in the Location field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
Location = Right(Location, Len(Location) - 1)
For Each varItem In Me!Method.ItemsSelected
Method = Method & ",'" & Me!Method.ItemData(varItem) & "'"
Next varItem
If Len(Method) = 0 Then
MsgBox "You did not select anything in the Method field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
Method = Right(Method, Len(Method) - 1)
For Each varItem In Me!Point.ItemsSelected
Point = Point & ",'" & Me!Point.ItemData(varItem) & "'"
Next varItem
If Len(Point) = 0 Then
MsgBox "You did not select anything in the Point field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
Point = Right(Point, Len(Point) - 1)
For Each varItem In Me!Rank.ItemsSelected
Rank = Rank & ",'" & Me!Rank.ItemData(varItem) & "'"
Next varItem
If Len(Rank) = 0 Then
MsgBox "You did not select anything in the Rank field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
Rank = Right(Rank, Len(Rank) - 1)
strSQL = "SELECT * FROM tblDataEntry " & _"WHERE tblDataEntry.District
IN(" & District & ") AND tblDataEntry.Circumstance IN(" & Circumstance &
") AND tblDataEntry.Location IN(" & Location & ") AND tblDataEntry.Method
IN (" & Method & ") AND tblDataEntry.Point IN (" & Point & ") AND
tblDataEntry.Rank IN(" & Rank & ");"
qdf.SQL = strSQL
DoCmd.OpenQuery "qryMultiselect"
Set db = Nothing
Set qdf = Nothing
End Sub
I still need to add the textboxes, but I'm not sure where. (Please note that I'm still learning VBA).
Firstly, since you are repeatedly performing the same operation for each form control (in this case, constructing a comma-delimited string from the selected items), you can abstract this operation away into a function, and pass such function each List Box function.
For example, you could define a function such as:
Function SelectedItems(objBox As ListBox) As String
Dim strRtn As String, varItm
For Each varItm In objBox.ItemsSelected
strRtn = strRtn & ",'" & objBox.ItemData(varItm) & "'"
Next varItm
If strRtn <> vbNullString Then SelectedItems = Mid(strRtn, 2)
End Function
Which could then be evaluated with a List Box control argument, and would return either a null string ("") or a comma-delimited string of the selected items in the list box, e.g. something like:
?SelectedItems(Forms!Form1!List1)
'A','B'
Furthermore, since your form controls appear to be named consistently relative to the fields in your table, you could further condense your code to something along the following lines:
Private Sub Command62_Click()
Dim strSQL As String
Dim strArr As String
Dim varItm
For Each varItm In Array("District", "Circumstance", "Location", "Method", "Point", "Rank")
strArr = SelectedItems(Me.Controls(varItm))
If strArr <> vbNullString Then
strSQL = strSQL & "t." & varItm & " in (" & strArr & ") and "
End If
Next varItm
If strSQL <> vbNullString Then strSQL = "where " & Left(strSQL, Len(strSQL) - 5)
With CurrentDb.QueryDefs("qryMultiselect")
.SQL = "select * from tblDataEntry t " & strSQL
End With
DoCmd.OpenQuery "qryMultiselect"
End Sub
Note that the above is entirely untested.
Here, the main for each loop iterates over an array of strings corresponding to the names of your form controls and the names of your table fields.
For each form control in this array, the function obtains a comma-delimited string of the selected items in the control, and concatenates this with the existing SQL code only if one or more items have been selected.
As such, if not items are selected, the field will not feature in the SQL where clause.
If any filter has been selected, the trailing five characters (and) are trimmed from the end of the SQL string, and the where keyword is concatenated to the start of the SQL string - this ensures that if no filter has been selected, the resulting SQL code will not include a where clause.
Finally, the SQL for the query definition is updated and the query is opened, per your original code.
Where textboxes are concerned, the task merely need to skip the call to SelectedItems and obtain the value of the textbox directly.
Here is an example incorporating both listboxes & textboxes:
Private Sub Command62_Click()
Dim strSQL As String
Dim strArr As String
Dim varItm
For Each varItm In Array("District", "Circumstance", "Location", "Method", "Point", "Rank")
strArr = vbNullString
Select Case Me.Controls(varItm).ControlType
Case acListBox
strArr = SelectedItems(Me.Controls(varItm))
Case acTextBox
If Not IsNull(Me.Controls(varItm).Value) Then
strArr = "'" & Me.Controls(varItm).Value & "'"
End If
End Select
If strArr <> vbNullString Then
strSQL = strSQL & "t." & varItm & " in (" & strArr & ") and "
End If
Next varItm
If strSQL <> vbNullString Then strSQL = "where " & Left(strSQL, Len(strSQL) - 5)
With CurrentDb.QueryDefs("qryMultiselect")
.SQL = "select * from tblDataEntry t " & strSQL
End With
DoCmd.OpenQuery "qryMultiselect"
End Sub
I hope this helps, but please note that the above is untested and only theory.

How to solve vba runtime error 3420

I have the following the detect duplicate product name when user enters a new record.
Private Sub ProdName_BeforeUpdate(Cancel As Integer)
Dim Product As String
Dim stLinkCriteria As String
Dim rsc As DAO.Recordset
Set rsc = Me.RecordsetClone
Product = Me.ProdName.value
stLinkCriteria = "[ProdName]=" & "'" & Product & "'"
If DCount("ProdName", "ProdProduct", stLinkCriteria) > 0 Then
Me.Undo
MsgBox "Warning duplicate entry " _
& Product & " has already been entered." _
& vbCr & vbCr & "You will now be taken to the record.", vbInformation _
, "Duplicate Information"
'Go to record of original product name
rsc.FindFirst stLinkCriteria
Me.Bookmark = rsc.Bookmark
End If
Set rsc = Nothing
End Sub
The code checks and finds duplicate but after it displays the following error and doesn't go to the orginal record:
Run-time error '3420'
Object invalid or no longer set
Please can someone help me get it right?
Try to avoid the undo (or move it to the end) and do cancel the update:
If DCount("ProdName", "ProdProduct", stLinkCriteria) > 0 Then
Cancel = True
MsgBox "Warning duplicate entry " _
& Product & " has already been entered." _
& vbCr & vbCr & "You will now be taken to the record.", vbInformation _
, "Duplicate Information"
'Go to record of original product name
rsc.FindFirst stLinkCriteria
Me.Bookmark = rsc.Bookmark
End If
And you may even skip the DCount and must use the Text property:
Product = Me!ProdName.Text
stLinkCriteria = "[ProdName]=" & "'" & Product & "'"
rsc.FindFirst stLinkCriteria
Cancel = Not rsc.NoMatch
If Cancel = True Then
MsgBox "Warning duplicate entry " _
& Product & " has already been entered." _
& vbCr & vbCr & "You will now be taken to the record.", vbInformation _
, "Duplicate Information"
'Go to record of original product name
Me.Bookmark = rsc.Bookmark
End If
The Run-time Error 3420, Object Invalid or No Longer Set occurs when the form status is dirty, you can simply set the form dirty to false before .findFirst call.
If Me.Dirty Then
Me.Dirty = False
End If
Me.Recordset.FindFirst stLinkCriteria

How to open Access report in a subform/subreport of the main form that houses the controls

I have this MS Access VBA code, using MS Access 2016.
Private Sub cmdPreview_Click()
On Error GoTo Err_Handler
Dim strReport As String
Dim strDateField As String
Dim strWhere As String
Dim lngView As Long
Const strcJetDate = "\#mm\/dd\/yyyy\#"
strReport = "Sales Report V2"
strDateField = "[OrderDate]"
lngView = acViewReport
If IsDate(Me.txtStartDate) Then
strWhere = "(" & strDateField & " >= " & Format(Me.txtStartDate, strcJetDate) & ")"
End If
If IsDate(Me.txtEndDate) Then
If strWhere <> vbNullString Then
strWhere = strWhere & " AND "
End If
strWhere = strWhere & "(" & strDateField & " < " & Format(Me.txtEndDate + 1, strcJetDate) & ")"
End If
If CurrentProject.AllReports(strReport).IsLoaded Then
DoCmd.Close acReport, strReport
End If
DoCmd.OpenReport strReport, lngView, , strWhere
Exit_Handler:
Exit Sub
Err_Handler:
If Err.Number <> 2501 Then
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "Cannot open Report"
End If
Resume Exit_Handler
End Sub
The is the the code is use to make date range form work. The form lets you pick a start date and an end date. You then click a button that calls the above code and the report is generated in an new tab. What I want to achieve but have not been able to figure out so far. Is how to make the report show up in a subform/subreport of the form that contains the date range controls and then from there have a button that is clicked to open the generated report in a new tab or printing or whatever if the user is happy with the selection.
This code is from a tutorial located at www.allenbrowne.com/casu-08.html
You can set the Filter property of the enclosed report:
Me!NameOfYourSubreportControl.Report.Filter = strWhere
Me!NameOfYourSubreportControl.Report.FilterOn = True
To open the report the normal way, use your existing code.

Re-Link to new mdb then delete old database (mdb)

I have a procedure where the ultimate objective is to update all tables on a server backend database from a laptop. Once this is complete, I want to delete the local (laptop) mdb and replace the deleted file (mdb) with the server mdb.
All seems to work well except I can't delete the local version even though I have re-linked the laptop front end to the server backend. Here is my code:
Call CloseALLFormsReports
Call RelinkTables("K:\Proposals\Northway\Data\Northway Data.accdb")
******************************************
'backup current c: database
tBackupfile = "C:\Proposals\backup\Northway DATA" & Format(Now(), "yyyymmdd hhmm") & ".accdb"
Call TransferBEData("C:\Proposals\Northway DATA.accdb", tBackupfile)
'now overwrite c:drive file
Call TransferBEData("K:\Proposals\Northway\Data\Northway Data.accdb", "C:\Proposals\Northway DATA.accdb")
Call RelinkTables("C:\Proposals\Northway DATA.accdb")
*************HERE IS THE TransferBEDate function:
Function TransferBEData(ByVal tSource As String, ByVal tDestination As String)
If FileExists(tDestination) Then
Kill tDestination
End If
FileCopy tSource, tDestination
End Function
************HERE IS MY Relinking Function
Public Sub RelinkTables(strNewPath As String)
Dim dbs As DAO.Database
Dim tdf As TableDef
Dim intCount As Integer
Dim frmCurrentForm As Form
Dim relink As Boolean
DoCmd.Hourglass True
On Error GoTo ErrLinkUpExit
'Me.lblMsg.Visible = True
'Me.cmdOK.Enabled = False
Set dbs = CurrentDb
For intCount = 0 To dbs.TableDefs.Count - 1
Set tdf = dbs.TableDefs(intCount)
If tdf.Connect <> "" Then
'Me.lblMsg.Caption = "Refreshing " & tdf.Name
DoEvents
tdf.Connect = ";DATABASE=" & strNewPath
tdf.RefreshLink
End If ' tdf.Connect <> ""
Next intCount
Set dbs = Nothing
Set tdf = Nothing
DoCmd.Hourglass False
MsgBox ("The file: " & strNewPath & " was successfully linked.")
'Me.lblMsg.Caption = "All Links were refreshed!"
relink = True
'Me.cmdOK.Enabled = True
Exit Sub
ErrLinkUpExit:
DoCmd.Hourglass False
Select Case Err
Case 3031 ' Password Protected
MsgBox "Back End '" & strNewPath & "'" & " is password protected"
Case 3011 ' Table missing
DoCmd.Hourglass False
MsgBox "Back End does not contain required table '" & _
tdf.SourceTableName & "'"
Case 3024 ' Back End not found
MsgBox "Back End Database '" & strNewPath & "'" & " " & _
"Not Found"
Case 3051 ' Access Denied
MsgBox "Access to '" & strNewPath & "' Denied " & _
vbCrLf & _
" May be Network Security or Read Only Database"
Case 3027 ' Read Only
MsgBox "Back End '" & strNewPath & "'" & " is Read " & _
"Only "
Case 3044 ' Invalid Path
MsgBox strNewPath & " Is Not a Valid Path"
Case 3265
MsgBox "Table '" & tdf.Name & "'" & _
" Not Found in ' " & strNewPath & "'"
Case 3321 ' Nothing Entered
MsgBox "No Database Name Entered"
Case Else
MsgBox "Uncaptured Error " & Str(Err) & " " & _
Err.Description
End Select
Set tdf = Nothing
relink = False
'******************Get rid of blank records
DoCmd.SetWarnings False
DoCmd.OpenQuery "Delete_Blank_Material_Records"
DoCmd.SetWarnings True
'********************************************
End Sub
Function TransferBEData(ByVal tSource As String, ByVal tDestination As String)
If FileExists(tDestination) Then
Kill tDestination
End If
FileCopy tSource, tDestination
End Function
The reason this doesn't work, is because re-linking the tables to another source will not delete the entry from the .mdw lock file (or security equivalent in later versions than 03). You would need to close your front-end database and then re-open in order to unlock the local .mdb file.