1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
|
Option Compare Database
Option Explicit
Global Const apErrDeviceNotAvlble = 68
Global Const apErrFileNotFound = 3024
Global Const apErrPathNotValid = 3044
Global Const apErrTableNotFound = 3078
Global Const apErrComDlgCancel = 32755
Global Const apErrDBCorrupted = -1
Global gstrAppPath As String
Global gstrBackEndPath As String
Global gstrBackendName As String
Public intRepEdited As Integer
Sub ap_AppInit()
Dim dbLocal As Database, dbNet As Database
Dim dynSharedTables As Recordset, dynTestTable As Recordset
Dim intCurrError As Integer, strCurrError As String
Dim blnLeaveApplication As Boolean
DoEvents
DoCmd.Echo True, "Checking Connections..."
blnLeaveApplication = False
Set dbLocal = CurrentDb()
'-- Section 1: Grab both the frontend and backend Datbases' Path
gstrAppPath = Left$(dbLocal.Name, ap_LastInStr(dbLocal.Name, "\"))
gstrBackendName = ap_GetDatabaseProp(dbLocal, "BackEndName")
gstrBackEndPath = ap_GetDatabaseProp(dbLocal, "LastBackEndPath")
'-- Section 2: User requested to logout, quit the application
'If ap_LogOutCheck(gstrBackEndPath) Then
' Beep
' MsgBox "Maintenance is being performed on the backend" & vbCrLf _
' & vbCrLf & "All users are requested to logout at this time.", _
' vbOKOnly + vbCritical, "Logging Out for Maintenance"
' Application.Quit
' Exit Function
'End If
'-- Section 3: Open the table containing the list of linked tables
Set dynSharedTables = dbLocal.OpenRecordset("SharedTables", dbOpenDynaset)
On Error Resume Next
Set dynTestTable = dbLocal.OpenRecordset(dynSharedTables!TableName, dbOpenDynaset)
intCurrError = Err.Number
strCurrError = Err.Description
Do Until intCurrError = 0
On Error GoTo Error_ap_App_Init
Select Case intCurrError
Case apErrFileNotFound, apErrTableNotFound, _
apErrPathNotValid, apErrDeviceNotAvlble
'-- Section 4: If the Data MDB is found in the App Dirctory,
'-- link the files.
If Dir(gstrAppPath & gstrBackendName) = gstrBackendName Then
ap_LinkTables dbLocal, dynSharedTables, gstrAppPath & _
gstrBackendName
gstrBackEndPath = gstrAppPath
Else
'-- Section 5: Allow the user to locate the BackEnd MDB
If Not ap_LocateBackend(dbLocal, dynSharedTables, _
strCurrError) Then
blnLeaveApplication = True
End If
End If
Case apErrDBCorrupted
'-- Section 6: Backend Corrupted. Repair?
Beep
If MsgBox("The Backend Database is Corrupted." & vbCrLf & _
vbCrLf & "Would you like to log users out and " & _
" attempt to repair it?", vbYesNo + vbCritical, _
"Corrupted Backend!") = vbYes Then
' DoCmd.OpenForm "ap_RepairDatabase", acForm, , , , acDialog
Else
blnLeaveApplication = True
End If
End Select
'-- Section 7: Leave the application if requested
If blnLeaveApplication Then
Application.Quit
Exit Sub
End If
On Error Resume Next
'-- Section 8: Let's try and open the first table again.
dynSharedTables.MoveFirst
Set dynTestTable = dbLocal.OpenRecordset(dynSharedTables!TableName)
intCurrError = Err.Number
strCurrError = Err.Description
Loop
On Error GoTo Error_ap_App_Init
'-- Section 9: Check the version of the front end,
'-- and point to a new one if necessary
'Set dbNet = OpenDatabase(gstrBackEndPath & gstrBackendName)
'If ap_GetDatabaseProp(dbLocal, "FrontEndVersion") <> _
' ap_GetDatabaseProp(dbNet, "FrontEndVersion") Then
' Beep
' MsgBox ap_GetDatabaseProp(dbNet, "NewVersionMessage"), _
' vbInformation, "New Version Available"
' Application.Quit
'End If
'-- Section 10: Save the BackEnd path in the BackEndPath property
'-- for future use.
ap_SetDatabaseProp dbLocal, "LastBackEndPath", gstrBackEndPath
'-- Check for locally logged errors
' ap_ErrorCheckLocal
'-- Check for Replicated Tables
' ap_CheckReplicatedTables
'-- Turn on the Monitor Form
' DoCmd.OpenForm "UserLogOutMonitor", , , , , acHidden
'-- Section 11: Close the Splash Screen and Clean Up
' DoCmd.Close acForm, "SplashScreen"
' DoCmd.Echo True
dynSharedTables.Close
Exit_ap_App_Init:
Exit Sub
Error_ap_App_Init:
Beep
MsgBox "The following error occurred: " & Error$ & vbCrLf & _
vbCrLf & "The system will now be closed down!"
Application.Quit
End Sub
Function ap_LogOutCheck(strBackEndPath) As Integer
On Error Resume Next
ap_LogOutCheck = Dir(strBackEndPath & "LogOut.FLG", vbHidden) = "LogOut.FLG"
End Function
Function ap_FormIsOpen(strFormName As String) As Integer
Dim frmCurrent As Form
For Each frmCurrent In Forms
If frmCurrent.Name = strFormName Then
ap_FormIsOpen = True
Exit Function
End If
Next frmCurrent
End Function
Sub ap_SetDatabaseProp(dbDatabase As Database, strPropertyName As String, varValue As Variant)
dbDatabase.Containers!Databases.Documents("UserDefined").Properties(strPropertyName).Value = varValue
End Sub
Function ap_GetDatabaseProp(dbDatabase As Database, strPropertyName As String) As Variant
Dim strTemp As String
'-- Covers an Access bug of placing a chr(0) at the end
'-- of a property value if you look at it through the UI.
strTemp = dbDatabase.Containers!Databases.Documents("UserDefined") _
.Properties(strPropertyName).Value
ap_GetDatabaseProp = IIf(InStr(strTemp, Chr$(0)) <> 0, Left$(strTemp, _
Len(strTemp) - 1), strTemp)
End Function
Function ap_LastInStr(strSearched As String, strSought As String) As Integer
Dim intCurrVal As Integer, intLastPosition As Integer
intCurrVal = InStr(strSearched, strSought)
Do Until intCurrVal = 0
intLastPosition = intCurrVal
intCurrVal = InStr(intLastPosition + 1, strSearched, strSought)
Loop
ap_LastInStr = intLastPosition
End Function
Public Sub ap_LinkTables(dbLocal, dynSharedTables, strDataMDB As String)
On Error GoTo Error_ap_linkTables
dynSharedTables.MoveFirst
Do Until dynSharedTables.EOF
DoCmd.Echo True, "Linking " & dynSharedTables!TableName & "..."
On Error Resume Next
dbLocal.TableDefs.Delete (dynSharedTables!TableName)
On Error GoTo Error_ap_linkTables
DoCmd.TransferDatabase acLink, "Microsoft Access", strDataMDB, acTable, dynSharedTables!TableName, dynSharedTables!TableName
dynSharedTables.MoveNext
Loop
Exit_ap_linkTables:
Exit Sub
Error_ap_linkTables:
MsgBox Err.Description
Resume Exit_ap_linkTables
End Sub
Public Sub ap_LogOutRemove()
On Error Resume Next
SetAttr gstrBackEndPath & "LogOut.FLG", vbNormal
Kill gstrBackEndPath & "LogOut.FLG"
End Sub
Public Sub ap_LogOutCreate()
On Error Resume Next
'-- Create flag file
Open gstrBackEndPath & "LogOut.FLG" For Output Shared As #1
Close #1
SetAttr gstrBackEndPath & "LogOut.FLG", vbHidden
End Sub
Public Function ap_LocateBackend(dbLocal, dynSharedTables, strCurrError) As Boolean
Dim strDialog As String
ap_LocateBackend = True
DoCmd.Echo True
Beep
If MsgBox("A problem has occurred accessing the linked tables." & _
vbCrLf & vbCrLf & "The error was: " & strCurrError & vbCrLf & _
vbCrLf & "Would you like to locate the backend?", vbCritical + _
vbYesNo, "Error with Backend") = vbYes Then
'Set ocxDialog = Screen.ActiveForm!ocxDialogControl.Object
'With ocxDialog
' .Filename = gstrBackendName
' .InitDir = gstrAppPath
' .DialogTitle = "Please Locate " & gstrBackendName
' .Filter = gstrBackendName
' .CancelError = True
' .ShowOpen
'End With
'
strDialog = InputBox("Please locate " & gstrBackendName, "Enter Backend Path", gstrAppPath)
'If Err.Number <> apErrComDlgCancel Then
' DoEvents
ap_LinkTables dbLocal, dynSharedTables, strDialog & gstrBackendName
gstrBackEndPath = Left$(strDialog, _
ap_LastInStr(strDialog, "\"))
'
'Else
' ap_LocateBackend = False
'End If
Else
ap_LocateBackend = False
End If
Exit_ap_LocateBackend:
Exit Function
Error_ap_LocateBackend:
ap_LocateBackend = False
Resume Exit_ap_LocateBackend
End Function
Sub ap_CheckReplicatedTables()
Dim dbLocal As Database
Dim dynCheckRep As Recordset
Dim qdfUpdateRep As QueryDef
Dim strBackEndPath As String, strBackEndName As String
On Error GoTo Error_ap_CheckReplicatedTables
Set dbLocal = CurrentDb()
DoCmd.Echo True, "Checking for Replicated Tables..."
'-- Grab the backend and path
strBackEndPath = ap_GetDatabaseProp(dbLocal, "LastBackEndPath")
strBackEndName = ap_GetDatabaseProp(dbLocal, "BackEndName")
'-- Attach the backend replicated table
'-- and open the query that shows updated replicated tables
On Error Resume Next
dbLocal.TableDefs.Delete "BackEndReplicatedTables"
dbLocal.TableDefs.Refresh
On Error GoTo Error_ap_CheckReplicatedTables
DoCmd.TransferDatabase acLink, "Microsoft Access", strBackEndPath & strBackEndName, acTable, "ReplicatedTables", "BackEndReplicatedTables"
dbLocal.TableDefs.Refresh
Set dynCheckRep = dbLocal.OpenRecordset("qCheckBackEndReplication")
'-- If a table has been updated, loop through and
If Not dynCheckRep.RecordCount = 0 Then
Set qdfUpdateRep = dbLocal.QueryDefs("qUpdateLastReplication")
Do Until dynCheckRep.EOF
DoCmd.Echo True, "Replicating " & dynCheckRep!TableName & ", Please wait..."
'-- Delete the current local table,
'-- and import the backend table
dbLocal.TableDefs.Delete dynCheckRep!TableName
dbLocal.TableDefs.Refresh
DoCmd.TransferDatabase acImport, "Microsoft Access", strBackEndPath & strBackEndName, acTable, dynCheckRep!TableName, dynCheckRep!TableName
CurrentDb.TableDefs.Refresh
qdfUpdateRep.PARAMETERS("CurrReplicatedTable") = dynCheckRep!TableName
qdfUpdateRep.Execute
dynCheckRep.MoveNext
Loop
qdfUpdateRep.Close
End If
dbLocal.TableDefs.Delete "BackEndReplicatedTables"
DoCmd.Echo True
'-- Clean up
dynCheckRep.Close
Exit Sub
Error_ap_CheckReplicatedTables:
MsgBox Err.Description
Exit Sub
End Sub |
setup module ?
Répondre avec citation
Envoyé par Arkham46
Partager