Option Compare Database Option Explicit Function testRev() Call MakeRevisions(6) End Function Public Function MakeRevisions(revProj_ID As Long, Optional blnRequireOldMatch As Boolean) ''makes revisions in RevisionTable, given a revisionProject_ID 'if blnRequireOldMatch, then it only updates the value if the old value matches exactly (or closely for double data type) On Error GoTo revErr Dim cnnloc As Connection Set cnnloc = CurrentProject.Connection Dim rstCurr As New ADODB.Recordset 'open appropriate revisions rstCurr.Open "SELECT * FROM revision WHERE revisionPRoject_ID = " & revProj_ID & " and revisionDate is null;", _ cnnloc, adOpenForwardOnly, adLockOptimistic, adCmdText With rstCurr Dim intLoop As Long Dim t_ReviseVal As String, t_newVal As String, t_oldVal As String Dim n_ReviseVal As Double, n_newVal As Double, n_oldVal As Double Dim b_ReviseVal As Boolean, b_newVal As Boolean, b_oldVal As Boolean Dim v_ReviseVal As Variant, v_newVal As Variant, v_oldVal As Variant Do Until .EOF intLoop = intLoop + 1 Dim rstTemp As New ADODB.Recordset ''define SQL to open table to edit: Dim strSQL2Ed As String If IsNull(!PK) Then 'Only works for File1-File4 strSQL2Ed = "SELECT [" & !Field & "] FROM [" & !table & "] WHERE [" & !PKName & "] = """ _ & !plotID & """;" Else strSQL2Ed = "SELECT [" & !Field & "] FROM [" & !table & "] WHERE [" & !PKName & "] = " _ & !PK & ";" End If rstTemp.Open strSQL2Ed, _ cnnloc, adOpenDynamic, adLockOptimistic, adCmdText If .EOF Then MsgBox "ERROR, couldn't find a record for revision_ID: " & !revision_ID & " (this is also recorded in the immediate log)" Debug.Print "ERROR, couldn't find a record for revision_ID: " & !revision_ID Else Dim blnMatchOld As Boolean, blnMatchNew As Boolean, strThese As String, strDataType As String strDataType = getDataTypeOfField(!table, !Field) Select Case strDataType Case "long integer", "double" n_ReviseVal = Nz((rstTemp.Fields((!Field))), -87421.254) n_newVal = Nz((!NewValue), -87421.254) n_oldVal = Nz((!OldValue), -87421.254) 'matching old or new values: blnMatchOld = ((n_ReviseVal) = (n_oldVal)) blnMatchNew = ((n_ReviseVal) = (n_newVal)) ''report what the current values are, if errors strThese = n_ReviseVal & " | " & n_oldVal & " , " & n_newVal '--catch errors if values are exceptionally close (<10^-8) If Not (blnMatchOld) Then If Abs(n_ReviseVal - n_oldVal) < 0.00000001 Then blnMatchOld = True Debug.Print intLoop & "--- old exceptionally close ---" End If End If If Not (blnMatchNew) Then If Abs(n_ReviseVal - n_newVal) < 0.00000001 Then blnMatchNew = True Debug.Print intLoop & "--- new exceptionally close ---" End If End If Case "text" t_ReviseVal = Nz((rstTemp.Fields((!Field))), "@NULL@") t_newVal = Nz((!NewValue), "@NULL@") t_oldVal = Nz((!OldValue), "@NULL@") blnMatchOld = ((t_ReviseVal) = (t_oldVal)) blnMatchNew = ((t_ReviseVal) = (t_newVal)) strThese = t_ReviseVal & " | " & t_oldVal & " , " & t_newVal Case "boolean" b_ReviseVal = Nz((rstTemp.Fields((!Field))), False) b_newVal = Nz((!NewValue), False) b_oldVal = Nz((!OldValue), False) blnMatchOld = ((b_ReviseVal) = (b_oldVal)) blnMatchNew = ((b_ReviseVal) = (b_newVal)) strThese = b_ReviseVal & " | " & b_oldVal & " , " & b_newVal Case "date/time" v_ReviseVal = Nz((rstTemp.Fields((!Field))), "@NULL@") v_newVal = Nz((!NewValue), "@NULL@") v_oldVal = Nz((!OldValue), "@NULL@") blnMatchOld = ((v_ReviseVal) = (v_oldVal)) blnMatchNew = ((v_ReviseVal) = (v_newVal)) strThese = v_ReviseVal & " | " & v_oldVal & " , " & v_newVal Case Else MsgBox "did not find data type for Table: " & !table & ", field: " & !Field & " type found: " & strDataType End Select ' reviseVal = Nz((rstTemp.Fields((!Field))), "@NULL@") ' newVal = Nz((!NewValue), "@NULL@") 'oldVal = Nz((!OldValue), "@NULL@") If blnMatchOld Or Not blnRequireOldMatch Then ''old value matches, or we don't require that '--make revision Debug.Print intLoop & " -- " & !NewValue & " inserting for " & !Field & " over value:" & !OldValue On Error GoTo cantUpdate rstTemp.Fields((!Field)).Value = !NewValue rstTemp.Update 'tell log that this one succeeded Debug.Print intLoop & ": success!" !revisionDate = Now() .Update afterUpdateAtt: On Error GoTo revErr Else ' doesn't match old val If blnMatchNew Then 'matches new values, revision already happened! Debug.Print intLoop & "-- already there!" & !revision_ID Else 'error, doesn't match new value either Debug.Print "DNMatch : " & strThese MsgBox "ERROR, field values do not match:" & !revision_ID End If ''matches new value End If End If 'EOF rstTemp.Close .MoveNext Loop End With exitthis: Exit Function cantUpdate: MsgBox ("Error in updating field, loop # = " & intLoop & " -- " & Err.Description & " see log.") rstTemp.CancelUpdate Resume afterUpdateAtt revErr: Call MsgBox("UNEXPECTED ERROR IN REVISIONS!" & Chr(13) & Err.Description, vbCritical) Resume exitthis End Function Function getDataTypeOfField(strTable As String, strFld As String) As String ''gets the data type (ie boolean, long integer, double, text) of a field in this database On Error GoTo cantFind Dim dbsCurr As Object Set dbsCurr = CurrentDb Dim tdfCurr As Object, fldCurr As Object Set tdfCurr = dbsCurr.tabledefs(strTable) Set fldCurr = tdfCurr.Fields(strFld) Dim intType As Long getDataTypeOfField = Interpret_FieldTypeInt(fldCurr.Type, fldCurr.Attributes) exitthis: Exit Function cantFind: getDataTypeOfField = "" Debug.Print "Couldn't find info on: " & strTable & "." & strFld & " -- " & Err.Description Resume exitthis End Function Public Function Interpret_FieldTypeInt(intType As Integer, intAttributes As Integer) As String 'takes a field type number and converts to access string Dim strTemp As String Select Case intType Case 1 strTemp = "Yes/No" Case 4 If intAttributes = 17 Then strTemp = "AutoNumber" Else strTemp = "Long Integer" End If Case 7 strTemp = "Double" Case 8 strTemp = "Date/Time" Case 10 strTemp = "Text" Case 11 strTemp = "OLE Object" Case 12 strTemp = "Memo" Case Else strTemp = "unknown!" End Select Interpret_FieldTypeInt = strTemp End Function