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
| ' Licence to http://creativecommons.org/licenses/by/3.0/
Option Compare Database
Option Explicit
Private Const TIMEOUT = 60
Public Sub Restart(Optional Compact As Boolean = False)
' L'option Compact pour un compactage !!
Dim scriptpath As String
scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat"
MsgBox scriptpath
If Dir(scriptpath, vbNormal) <> "" Then
If DateAdd("s", TIMEOUT * 2, FileDateTime(scriptpath)) < Date Then
Kill scriptpath
Else
Application.Quit acQuitSaveAll
Exit Sub
End If
End If
Dim s As String
s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf
s = s & "SET /a counter=0" & vbCrLf
s = s & ":CHECKLOCKFILE" & vbCrLf
s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf
s = s & "SET /a counter+=1" & vbCrLf
s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf
s = s & "IF EXIST ""%~f2.%4"" GOTO CHECKLOCKFILE" & vbCrLf
If VerificationMaJ <> "Aucun" Then
s = s & "COPY " & VerificationMaJ & " " & Application.CurrentProject.FullName & vbCrLf
End If
If Compact Then
s = s & """%~f1"" ""%~f2.%3"" /compact" & vbCrLf
End If
s = s & "start "" "" ""%~f2.%3""" & vbCrLf
s = s & ":CLEANUP" & vbCrLf
s = s & "del %0"
Debug.Print s
' Enregistrement du script construit plus haut
Dim intFile As Integer
intFile = FreeFile()
Open scriptpath For Output As #intFile
Print #intFile, s
Close #intFile
Dim dbname As String, ext As String, lockext As String, accesspath As String
Dim idx As Integer
accesspath = SysCmd(acSysCmdAccessDir) & "msaccess.exe"
' Retrouve l'extension du frontal
For idx = Len(CurrentProject.FullName) To 1 Step -1
If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For
Next idx
dbname = Left(CurrentProject.FullName, idx - 1)
ext = Mid(CurrentProject.FullName, idx + 1)
' En fonction du frontal on détermine l'extension du fichier de verrouillage
If Left(ext, 2) = "ac" Then
lockext = "laccdb"
Else
lockext = "ldb"
End If
' Appel du script
s = """" & scriptpath & """ """ & accesspath & """ """ & dbname & """ " & ext & " " & lockext
Shell s, vbHide
' Ferme l'appli
Application.Quit acQuitSaveAll
End Sub
Function VerificationMaJ() As String
'Fonction de test existence si oui compare les dates
'La fonction retourne l'emplacement et le nom du nouveau fichier
Dim EmplacementFrt As String
Dim ladateLocal
Dim ladateFrontalMaJ
Dim rst As New ADODB.Recordset
rst.Open "tbl_version", CurrentProject.Connection, adOpenStatic, adLockReadOnly
rst.MoveFirst
ladateLocal = rst!version_date
EmplacementFrt = Nz(rst!version_namefrontal)
rst.Close: Set rst = Nothing
If FichierExiste(EmplacementFrt) = True Then
'Recherche la date sur Frontal MàJ
ladateFrontalMaJ = donneladate(EmplacementFrt)
Else
'Le fichier de MàJ n'existe pas
VerificationMaJ = "Aucun"
Exit Function
End If
If ladateFrontalMaJ > ladateLocal Then
VerificationMaJ = EmplacementFrt
Else
VerificationMaJ = "Aucun"
End If
End Function
Function donneladate(kelbase)
'Connexion au frontal et interrogation de la date
Dim conn, strConnect, rs
Dim leSQL As String
Set conn = CreateObject("ADODB.Connection")
strConnect = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & kelbase & ";Persist Security Info=False;"
conn.Open strConnect
leSQL = "SELECT tbl_version.version_date FROM tbl_version"
Set rs = conn.Execute(leSQL)
rs.MoveFirst
donneladate = rs(0)
conn.Close
Set conn = Nothing
End Function
Function FichierExiste(leFichier As String) As Boolean
' Le fichier existe ?
Dim filesys
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists(leFichier) Then
FichierExiste = True
End If
End Function
Function MAJauto()
'Vérification de l'éxistance du fichier et contrôle de la date
If VerificationMaJ <> "Aucun" Then
MsgBox "Une mise à jour du frontal est disponible !" + vbCrLf + "Le programme va se fermer puis redémarrer." + vbCrLf + "Veuillez patienter", vbInformation, "Attention"
Restart
End If
End Function |
mise à jour base frontale à l'ouverture
Répondre avec citation
Partager