|
1
|
Option Compare Database
|
|
2
|
Option Explicit
|
|
3
|
|
|
4
|
Function testRev()
|
|
5
|
Call MakeRevisions(6)
|
|
6
|
|
|
7
|
End Function
|
|
8
|
|
|
9
|
Public Function MakeRevisions(revProj_ID As Long, Optional blnRequireOldMatch As Boolean)
|
|
10
|
''makes revisions in RevisionTable, given a revisionProject_ID
|
|
11
|
'if blnRequireOldMatch, then it only updates the value if the old value matches exactly (or closely for double data type)
|
|
12
|
On Error GoTo revErr
|
|
13
|
Dim cnnloc As Connection
|
|
14
|
Set cnnloc = CurrentProject.Connection
|
|
15
|
Dim rstCurr As New ADODB.Recordset
|
|
16
|
'open appropriate revisions
|
|
17
|
rstCurr.Open "SELECT * FROM revision WHERE revisionPRoject_ID = " & revProj_ID & " and revisionDate is null;", _
|
|
18
|
cnnloc, adOpenForwardOnly, adLockOptimistic, adCmdText
|
|
19
|
With rstCurr
|
|
20
|
Dim intLoop As Long
|
|
21
|
Dim t_ReviseVal As String, t_newVal As String, t_oldVal As String
|
|
22
|
Dim n_ReviseVal As Double, n_newVal As Double, n_oldVal As Double
|
|
23
|
Dim b_ReviseVal As Boolean, b_newVal As Boolean, b_oldVal As Boolean
|
|
24
|
Dim v_ReviseVal As Variant, v_newVal As Variant, v_oldVal As Variant
|
|
25
|
Do Until .EOF
|
|
26
|
intLoop = intLoop + 1
|
|
27
|
Dim rstTemp As New ADODB.Recordset
|
|
28
|
''define SQL to open table to edit:
|
|
29
|
Dim strSQL2Ed As String
|
|
30
|
If IsNull(!PK) Then 'Only works for File1-File4
|
|
31
|
strSQL2Ed = "SELECT [" & !Field & "] FROM [" & !table & "] WHERE [" & !PKName & "] = """ _
|
|
32
|
& !plotID & """;"
|
|
33
|
Else
|
|
34
|
strSQL2Ed = "SELECT [" & !Field & "] FROM [" & !table & "] WHERE [" & !PKName & "] = " _
|
|
35
|
& !PK & ";"
|
|
36
|
End If
|
|
37
|
rstTemp.Open strSQL2Ed, _
|
|
38
|
cnnloc, adOpenDynamic, adLockOptimistic, adCmdText
|
|
39
|
If .EOF Then
|
|
40
|
MsgBox "ERROR, couldn't find a record for revision_ID: " & !revision_ID & " (this is also recorded in the immediate log)"
|
|
41
|
Debug.Print "ERROR, couldn't find a record for revision_ID: " & !revision_ID
|
|
42
|
Else
|
|
43
|
Dim blnMatchOld As Boolean, blnMatchNew As Boolean, strThese As String, strDataType As String
|
|
44
|
strDataType = getDataTypeOfField(!table, !Field)
|
|
45
|
Select Case strDataType
|
|
46
|
Case "long integer", "double"
|
|
47
|
n_ReviseVal = Nz((rstTemp.Fields((!Field))), -87421.254)
|
|
48
|
n_newVal = Nz((!NewValue), -87421.254)
|
|
49
|
n_oldVal = Nz((!OldValue), -87421.254)
|
|
50
|
'matching old or new values:
|
|
51
|
blnMatchOld = ((n_ReviseVal) = (n_oldVal))
|
|
52
|
blnMatchNew = ((n_ReviseVal) = (n_newVal))
|
|
53
|
''report what the current values are, if errors
|
|
54
|
strThese = n_ReviseVal & " | " & n_oldVal & " , " & n_newVal
|
|
55
|
'--catch errors if values are exceptionally close (<10^-8)
|
|
56
|
If Not (blnMatchOld) Then
|
|
57
|
If Abs(n_ReviseVal - n_oldVal) < 0.00000001 Then
|
|
58
|
blnMatchOld = True
|
|
59
|
Debug.Print intLoop & "--- old exceptionally close ---"
|
|
60
|
End If
|
|
61
|
End If
|
|
62
|
If Not (blnMatchNew) Then
|
|
63
|
If Abs(n_ReviseVal - n_newVal) < 0.00000001 Then
|
|
64
|
blnMatchNew = True
|
|
65
|
Debug.Print intLoop & "--- new exceptionally close ---"
|
|
66
|
End If
|
|
67
|
End If
|
|
68
|
Case "text"
|
|
69
|
t_ReviseVal = Nz((rstTemp.Fields((!Field))), "@NULL@")
|
|
70
|
t_newVal = Nz((!NewValue), "@NULL@")
|
|
71
|
t_oldVal = Nz((!OldValue), "@NULL@")
|
|
72
|
blnMatchOld = ((t_ReviseVal) = (t_oldVal))
|
|
73
|
blnMatchNew = ((t_ReviseVal) = (t_newVal))
|
|
74
|
strThese = t_ReviseVal & " | " & t_oldVal & " , " & t_newVal
|
|
75
|
Case "boolean"
|
|
76
|
b_ReviseVal = Nz((rstTemp.Fields((!Field))), False)
|
|
77
|
b_newVal = Nz((!NewValue), False)
|
|
78
|
b_oldVal = Nz((!OldValue), False)
|
|
79
|
blnMatchOld = ((b_ReviseVal) = (b_oldVal))
|
|
80
|
blnMatchNew = ((b_ReviseVal) = (b_newVal))
|
|
81
|
strThese = b_ReviseVal & " | " & b_oldVal & " , " & b_newVal
|
|
82
|
Case "date/time"
|
|
83
|
v_ReviseVal = Nz((rstTemp.Fields((!Field))), "@NULL@")
|
|
84
|
v_newVal = Nz((!NewValue), "@NULL@")
|
|
85
|
v_oldVal = Nz((!OldValue), "@NULL@")
|
|
86
|
blnMatchOld = ((v_ReviseVal) = (v_oldVal))
|
|
87
|
blnMatchNew = ((v_ReviseVal) = (v_newVal))
|
|
88
|
strThese = v_ReviseVal & " | " & v_oldVal & " , " & v_newVal
|
|
89
|
Case Else
|
|
90
|
MsgBox "did not find data type for Table: " & !table & ", field: " & !Field & " type found: " & strDataType
|
|
91
|
End Select
|
|
92
|
' reviseVal = Nz((rstTemp.Fields((!Field))), "@NULL@")
|
|
93
|
' newVal = Nz((!NewValue), "@NULL@")
|
|
94
|
'oldVal = Nz((!OldValue), "@NULL@")
|
|
95
|
|
|
96
|
If blnMatchOld Or Not blnRequireOldMatch Then
|
|
97
|
''old value matches, or we don't require that
|
|
98
|
'--make revision
|
|
99
|
Debug.Print intLoop & " -- " & !NewValue & " inserting for " & !Field & " over value:" & !OldValue
|
|
100
|
On Error GoTo cantUpdate
|
|
101
|
rstTemp.Fields((!Field)).Value = !NewValue
|
|
102
|
rstTemp.Update
|
|
103
|
'tell log that this one succeeded
|
|
104
|
Debug.Print intLoop & ": success!"
|
|
105
|
!revisionDate = Now()
|
|
106
|
.Update
|
|
107
|
afterUpdateAtt:
|
|
108
|
On Error GoTo revErr
|
|
109
|
Else ' doesn't match old val
|
|
110
|
If blnMatchNew Then
|
|
111
|
'matches new values, revision already happened!
|
|
112
|
Debug.Print intLoop & "-- already there!" & !revision_ID
|
|
113
|
Else
|
|
114
|
'error, doesn't match new value either
|
|
115
|
Debug.Print "DNMatch : " & strThese
|
|
116
|
MsgBox "ERROR, field values do not match:" & !revision_ID
|
|
117
|
|
|
118
|
End If ''matches new value
|
|
119
|
End If
|
|
120
|
End If 'EOF
|
|
121
|
rstTemp.Close
|
|
122
|
.MoveNext
|
|
123
|
Loop
|
|
124
|
End With
|
|
125
|
exitthis:
|
|
126
|
Exit Function
|
|
127
|
cantUpdate:
|
|
128
|
MsgBox ("Error in updating field, loop # = " & intLoop & " -- " & Err.Description & " see log.")
|
|
129
|
rstTemp.CancelUpdate
|
|
130
|
Resume afterUpdateAtt
|
|
131
|
revErr:
|
|
132
|
Call MsgBox("UNEXPECTED ERROR IN REVISIONS!" & Chr(13) & Err.Description, vbCritical)
|
|
133
|
Resume exitthis
|
|
134
|
End Function
|
|
135
|
|
|
136
|
Function getDataTypeOfField(strTable As String, strFld As String) As String
|
|
137
|
''gets the data type (ie boolean, long integer, double, text) of a field in this database
|
|
138
|
On Error GoTo cantFind
|
|
139
|
Dim dbsCurr As Object
|
|
140
|
Set dbsCurr = CurrentDb
|
|
141
|
Dim tdfCurr As Object, fldCurr As Object
|
|
142
|
Set tdfCurr = dbsCurr.tabledefs(strTable)
|
|
143
|
Set fldCurr = tdfCurr.Fields(strFld)
|
|
144
|
Dim intType As Long
|
|
145
|
getDataTypeOfField = Interpret_FieldTypeInt(fldCurr.Type, fldCurr.Attributes)
|
|
146
|
exitthis:
|
|
147
|
Exit Function
|
|
148
|
cantFind:
|
|
149
|
getDataTypeOfField = ""
|
|
150
|
Debug.Print "Couldn't find info on: " & strTable & "." & strFld & " -- " & Err.Description
|
|
151
|
Resume exitthis
|
|
152
|
End Function
|
|
153
|
|
|
154
|
Public Function Interpret_FieldTypeInt(intType As Integer, intAttributes As Integer) As String
|
|
155
|
'takes a field type number and converts to access string
|
|
156
|
Dim strTemp As String
|
|
157
|
Select Case intType
|
|
158
|
Case 1
|
|
159
|
strTemp = "Yes/No"
|
|
160
|
Case 4
|
|
161
|
If intAttributes = 17 Then
|
|
162
|
strTemp = "AutoNumber"
|
|
163
|
Else
|
|
164
|
strTemp = "Long Integer"
|
|
165
|
End If
|
|
166
|
Case 7
|
|
167
|
strTemp = "Double"
|
|
168
|
Case 8
|
|
169
|
strTemp = "Date/Time"
|
|
170
|
Case 10
|
|
171
|
strTemp = "Text"
|
|
172
|
Case 11
|
|
173
|
strTemp = "OLE Object"
|
|
174
|
Case 12
|
|
175
|
strTemp = "Memo"
|
|
176
|
Case Else
|
|
177
|
strTemp = "unknown!"
|
|
178
|
End Select
|
|
179
|
Interpret_FieldTypeInt = strTemp
|
|
180
|
End Function
|