Discussion :

[melancolie]

bonjour.
je rencontre ce problème à l'installation de mon application sur un autre poste que le mien. j'ai fait des recherches mais elles se sont relevées infructueuses. aussi, je vous le soumet. dans un module, j'ai ce code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
Public Function IsLoadedForm(ByVal Frm As Form) As Boolean
    Dim F As Form
 
    For Each F In Forms
        If F Is Frm Then
            IsLoadedForm = True
            Exit For
        End If
    Next
End Function
 
Public Function ContrainteDateTime(TB As Variant, CheminSon As String) As Boolean
    ContrainteDate = False
    If TB.Text = "" Then Exit Function
 
    If IsDate(TB.Text) = False Then
        ContrainteDate = True
        JouerSon CheminSon
        MsgBox "Entrez une valeur de type ''DATE''.", , "Contrainte"
        Exit Function
    End If
 
    If InStr(TB.Text, ":") <> 0 Then
        TB.Text = Format(TB.Text, "hh:mm:ss")
      Else
        TB.Text = Format(TB.Text, "dd/MM/yyyy")
    End If
End Function
 
Function ValeurEnLettre(L As Double)
    Select Case Len(CStr(L))
        Case 1
            ValeurEnLettre = CHIFFRE_1(L)
        Case 2
            ValeurEnLettre = CHIFFRE_2(L)
        Case 3
            ValeurEnLettre = CHIFFRE_3(L)
        Case 4 To 6
            ValeurEnLettre = CHIFFRE_MILLE(L)
        Case Else
            ValeurEnLettre = CHIFFRE_MILLION(L)
    End Select
End Function
 
Private Function CHIFFRE_1(N As Double)
    Select Case N
        Case 1
            CHIFFRE_1 = "un"
        Case 2
            CHIFFRE_1 = "deux"
        Case 3
            CHIFFRE_1 = "trois"
        Case 4
            CHIFFRE_1 = "quatre"
        Case 5
            CHIFFRE_1 = "cinq"
        Case 6
            CHIFFRE_1 = "six"
        Case 7
            CHIFFRE_1 = "sept"
        Case 8
            CHIFFRE_1 = "huit"
        Case 9
            CHIFFRE_1 = "neuf"
    End Select
End Function
 
Private Function CHIFFRE_2(N As Double)
    Select Case N
        Case 10
            CHIFFRE_2 = "dix"
        Case 11
            CHIFFRE_2 = "onze"
        Case 12
            CHIFFRE_2 = "douze"
        Case 13
            CHIFFRE_2 = "treize"
        Case 14
            CHIFFRE_2 = "quatorze"
        Case 15
            CHIFFRE_2 = "quinze"
        Case 16
            CHIFFRE_2 = "seize"
        Case 20
            CHIFFRE_2 = "vingt"
        Case 30
            CHIFFRE_2 = "trente"
        Case 40
            CHIFFRE_2 = "quarante"
        Case 50
            CHIFFRE_2 = "cinquante"
        Case 60
            CHIFFRE_2 = "soixante"
        Case 70
            CHIFFRE_2 = "soixante-dix"
        Case 80
            CHIFFRE_2 = "quatre-vingts"
        Case 90
            CHIFFRE_2 = "quatre-vingt-dix"
        Case Else
            Dim Q As Double: Dim R As Double
            Q = 10 * Int(N / 10)
            R = N Mod 10
 
            Select Case N
                Case 71 To 79, 91 To 99
                    CHIFFRE_2 = CHIFFRE_2(Q - 10) & " " & CHIFFRE_2(R + 10)
                Case Else
                    If R = 1 Then
                        CHIFFRE_2 = CHIFFRE_2(Q) & "-un"
                      Else
                        CHIFFRE_2 = CHIFFRE_2(Q) & "-" & CHIFFRE_1(R)
                    End If
            End Select
    End Select
End Function
 
Private Function CHIFFRE_3(N As Double)
    Select Case N
        Case 100
            CHIFFRE_3 = "cent"
        Case Else
            Dim Q As Double: Dim R As Double
            Q = Int(N / 100)
            R = N Mod 100
            Dim C As String
 
            If Q = 1 Then
                C = "cent "
              Else
                C = CHIFFRE_1(Q) & " cents "
            End If
 
            Select Case R
                Case 1 To 9
                    C = C & CHIFFRE_1(R)
                Case 10 To 99
                    C = C & CHIFFRE_2(R)
            End Select
 
            CHIFFRE_3 = C
    End Select
End Function
 
Private Function CHIFFRE_MILLE(N As Double)
    Select Case N
        Case 1000
            CHIFFRE_MILLE = "mille "
        Case Else
            Dim Q As Double: Dim R As Double
            Q = Int(N / 1000)
            R = N Mod 1000
            Dim C As String
 
            Select Case Q
                Case 1
                    C = "mille "
                Case 2 To 9
                    C = CHIFFRE_1(Q) & " mille "
                Case 10 To 99
                    C = CHIFFRE_2(Q) & " mille "
                Case 100 To 999
                    C = CHIFFRE_3(Q) & " mille "
            End Select
 
            Select Case R
                Case 1 To 9
                    C = C & CHIFFRE_1(R)
                Case 10 To 99
                    C = C & CHIFFRE_2(R)
                Case 100 To 999
                    C = C & CHIFFRE_3(R)
            End Select
 
            CHIFFRE_MILLE = C
    End Select
End Function
 
Private Function CHIFFRE_MILLION(N As Double)
        Dim Q As Double: Dim R As Double
        Q = Int(N / 1000000)
        R = N Mod 1000000
        Dim C As String
 
        Select Case Q
            Case 1 To 9
                C = "un million "
            Case 2 To 9
                C = CHIFFRE_1(Q) & " millions "
            Case 10 To 99
                C = CHIFFRE_2(Q) & " millions "
            Case 100 To 999
                C = CHIFFRE_3(Q) & " millions "
        End Select
 
        Select Case R
            Case 1 To 9
                C = C & CHIFFRE_1(R)
            Case 10 To 99
                C = C & CHIFFRE_2(R)
            Case 100 To 999
                C = C & CHIFFRE_3(R)
            Case 1000 To 999999
                C = C & CHIFFRE_MILLE(R)
        End Select
 
        CHIFFRE_MILLION = C
End Function
 
Public Function ValiderDecimal(V)
    Dim P As Double
    P = InStr(V, ",")
 
    If P = 0 Then
        ValiderDecimal = V
      Else
        Dim D As Variant
        Dim G As Variant
 
        G = Left(CStr(V), P - 1)
        D = Right(CStr(V), Len(CStr(V)) - P)
 
        ValiderDecimal = G & "." & D
    End If
End Function
 
Public Sub KeyPressedInteger(K As Integer)
    Select Case K
        Case 1 To 31, 48 To 57
        Case Else
            Beep
            K = 0
    End Select
End Sub
 
Public Sub KeyPressedDecimal(K As Integer, bVal As String)
    Select Case K
        Case 1 To 31
            Exit Sub
    End Select
 
    If InStr(bVal, ",") <> 0 And (K = 44 Or K = 46) Then
        Beep
        K = 0
        Exit Sub
    End If
 
    Select Case K
        Case 48 To 57
        Case 46
            K = 44
        Case Else
            Beep
            K = 0
    End Select
End Sub
 
Public Sub KeyPressedDate(K As Integer)
    Select Case K
        Case 1 To 31, 45, 47 To 57
        Case Else
            Beep
            K = 0
    End Select
End Sub
 
Public Sub KeyPressedTime(K As Integer)
    Select Case K
        Case 1 To 31, 48 To 58
        Case Else
            Beep
            K = 0
    End Select
End Sub
 
Public Sub KeyPressedStringMaj(K As Integer)
    Select Case K
        Case 97 To 122, 224, 231, 232, 233, 249
            K = UCase(K)
    End Select
End Sub
 
Public Function KeyPressedChaineLimite(K As Integer, bStr As String, bLimite As Integer) As Boolean
    KeyPressedChaineLimite = False
 
    Select Case K
        Case 1 To 31
            KeyPressedChaineLimite = True
            Exit Function
    End Select
 
    If Len(bStr) = bLimite Then
        KeyPressedChaineLimite = True
        Beep
        K = 0
        Exit Function
    End If
End Function
 
Public Sub GestionDesErreurs(bTitre As String, CheminSon As String)
    Screen.MousePointer = 0
    Dim bStr As String
    bStr = Err.Description
 
    If bStr = "Type incompatible" Then
        bStr = "Vous avez une valeur de type inapproprié. Par exemple : du texte à la place de valeur numérique ou inversement."
        GoTo SUITE
    End If
 
    If bStr Like "Modification*" Then
        bStr = "Le matricule, le code ou la référence que vous avez saisi existe déjà." & vbLf & "Veuillez en saisir un autre."
        GoTo SUITE
    End If
 
    If bStr Like "*objet*ouvert*" Then
        bStr = "Fermez ce formulaire et ouvrez le de nouveau." & vbLf & "Si l'erreur persiste, fermez l'application et relancez la."
        GoTo SUITE
    End If
 
    If bStr Like "Vous avez essayé d'ouvrir une base de données*" Then
        bStr = "La base de données active est ouverte par un autre utilisateur." & vbLf & "Fermer LEHI sur tous les postes." & vbLf & "Rédemarrez votre poste."
        GoTo SUITE
    End If
 
    If bStr Like "Fichier*introuvable." Then
        bStr = "Impossible de se connecter à la base de données." & vbLf & "Elle a été déplacée ou effacée."
        GoTo SUITE
    End If
 
    If bStr Like "Le moteur de base de données Microsoft Jet ne peut pas trouver la table ou la requête source*" Then
        bStr = "La base de données sélectionnée n'est pas bonne." & vbLf & "Contactez l'administrateur pour en sélectionner une autre."
        GoTo SUITE
    End If
 
    If bStr = "La commande Annuler a été sélectionnée." Then Exit Sub
SUITE:
    JouerSon CheminSon
    MsgBox bStr, , bTitre
End Sub
 
Public Function ExtractFilePath(ByVal sFullPath As String) As String
    ExtractFilePath = ""
    On Error Resume Next
    Dim fName As String
    fName = ExtractFileName(sFullPath)
    ExtractFilePath = Left(sFullPath, Len(sFullPath) - (Len(fName) + 1))
End Function
 
Public Function ExtractFileExt(ByVal sFullPath As String) As String
    Dim sName As String
    sName = ExtractFileName(sFullPath)
 
    If InStr(sName, ".") = 0 Then
        ExtractFileExt = ""
    Else
        ExtractFileExt = Mid(sName, InStrRev(sName, ".") + 1)
    End If
End Function
 
Public Function ExtractFileName(ByVal sFullPath As String) As String
    If InStr(sFullPath, "\") = 0 Or Right(sFullPath, 1) = "\" Then
        ExtractFileName = ""
        Exit Function
    End If
 
    ExtractFileName = Mid(sFullPath, InStrRev(sFullPath, "\") + 1)
End Function
 
Public Function GetValue(Fld As Variant) As String
    If IsNull(Fld) Then
        GetValue = ""
     Else
        GetValue = Fld
    End If
End Function
 
Public Function NumeroColonne(N As Integer) As String
    Select Case N
        Case 0
            NumeroColonne = "A"
        Case 1
            NumeroColonne = "B"
        Case 2
            NumeroColonne = "C"
        Case 3
            NumeroColonne = "D"
        Case 4
            NumeroColonne = "E"
        Case 5
            NumeroColonne = "F"
        Case 6
            NumeroColonne = "G"
        Case 7
            NumeroColonne = "H"
        Case 8
            NumeroColonne = "I"
        Case 9
            NumeroColonne = "J"
        Case 10
            NumeroColonne = "K"
        Case 11
            NumeroColonne = "L"
        Case 12
            NumeroColonne = "M"
        Case 13
            NumeroColonne = "N"
        Case 14
            NumeroColonne = "O"
        Case 15
            NumeroColonne = "P"
        Case 16
            NumeroColonne = "Q"
        Case 17
            NumeroColonne = "R"
        Case 18
            NumeroColonne = "S"
        Case 19
            NumeroColonne = "T"
        Case 20
            NumeroColonne = "U"
        Case 21
            NumeroColonne = "V"
        Case 22
            NumeroColonne = "W"
        Case 23
            NumeroColonne = "X"
        Case 24
            NumeroColonne = "Y"
        Case 25
            NumeroColonne = "Z"
    End Select
End Function
 
Public Function IsFileOpen(ByVal strFic As String) As Boolean
    Dim fic As Integer
    On Error Resume Next
    fic = FreeFile()
    Open strFic For Input Access Read Lock Read Write As fic
 
    If Err.Number = 0 Then
        IsFileOpen = False
        Close fic
      Else
        IsFileOpen = True
    End If
End Function
 
 
Public Sub JouerSon(ByVal NomDuFichier As String, Optional ByVal Attente As Boolean = False)
    If Attente Then
        Call PlaySound(NomDuFichier, SND_SYNC, SND_FILENAME)
      Else
        Call PlaySound(NomDuFichier, SND_SYNC, SND_ASYNC Or SND_FILENAME)
    End If
End Sub
 
 
Public Function FinMois(bMois As String, bAnnee As String) As String
    Select Case bMois
        Case "janvier"
            FinMois = "31"
        Case "février"
            If Val(bAnnee) Mod 4 = 0 Then
                FinMois = "29"
              Else
                FinMois = "28"
            End If
        Case "mars"
            FinMois = "31"
        Case "avril"
            FinMois = "30"
        Case "mai"
            FinMois = "31"
        Case "juin"
            FinMois = "30"
        Case "juillet"
            FinMois = "31"
        Case "août"
            FinMois = "31"
        Case "septembre"
            FinMois = "30"
        Case "octobre"
            FinMois = "31"
        Case "novembre"
            FinMois = "30"
        Case "décembre"
            FinMois = "31"
    End Select
End Function
 
Public Sub SaisieAssistee(bCombo As Variant, RefuseValeurEntree As Boolean)
    If bCombo.Text = "" Then Exit Sub
 
    Static NoSelectText As String   ' texte tapé par l'utilisateur
    Dim I As Double                   ' compteur de boucle
 
    With bCombo '<== SEULE LIGNE A MODIFIER
        ' touche que l'on ne doit pas gérer dans cette procedure
        If KeyCode = vbKeyUp Then Exit Sub      ' utilisé par VB
        If KeyCode = vbKeyDown Then Exit Sub    ' utilisé par vb
        If KeyCode = vbKeyLeft Then Exit Sub    ' pour se déplacer
        If KeyCode = vbKeyRight Then Exit Sub   ' pour se déplacer
 
        ' action spécial pour la touche BACK
        If KeyCode <> vbKeyBack Then
            NoSelectText = Mid(.Text, 1, Len(.Text) - .SelLength)
          Else
            If NoSelectText <> "" Then NoSelectText = Mid(NoSelectText, 1, Len(NoSelectText) - 1)
        End If
 
        ' recherche de la correspondance
        For I = 0 To .ListCount - 1
            If UCase(NoSelectText) = UCase(Mid(.List(I), 1, Len(NoSelectText))) Then
                .ListIndex = I
                Exit For
            End If
        Next
 
        ' selection de la partie que l'on a rajouté automatiquement
        .SelStart = Len(NoSelectText)
        .SelLength = Len(.Text)
 
        ' partie optionnelle qui change la couleur de fond en cas d'erreur
        If .ListIndex <> -1 Then Exit Sub
    End With
 
    If RefuseValeurEntree = False Then Exit Sub
    Beep
    MsgBox "Entrez une valeur de la liste.", , bTitre
    On Error Resume Next
    SendKeys "^z"
End Sub
 
Public Function RemplacerCaractere39(bVal As Variant) As String
    If InStr(bVal, "'") = 0 Then
        RemplacerCaractere39 = bVal
      Else
        RemplacerCaractere39 = Replace(bVal, "'", "''")
    End If
End Function
 
Public Function BooleanInString(bVal As Boolean) As String
    If bVal Then
        BooleanInString = "Oui"
      Else
        BooleanInString = "Non"
    End If
End Function
 
Public Function StringInBoolean(bVal As String) As String
    If bVal = "Oui" Then
        StringInBoolean = "True"
      Else
        StringInBoolean = "False"
    End If
End Function

dans la procédure de démarrage, j'ai ce code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Public MDIFormAlreadyLoaded As Boolean
Public CheminSon As String
Public MleUtilisateur As String
Public ProfilUtilisateur As String
 
Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal FichierExistant As String, ByVal Fichier_A_Créer As String, _
ByVal ErreurExistance As Long) As Long
 
Public bConnActive As Connection
Public bConnShape As Connection
Public ConnRegistre As Connection
Public bConnSecurite As Connection
 
Public feuilleActive As String
Public bAddMode As Boolean
Dim ReferenceSecurite As String
 
Public Reconnexion As Boolean
 
Sub Main()
    On Error GoTo GestErr
    Set ConnRegistre = New Connection
    ConnRegistre.CursorLocation = adUseClient
    ConnRegistre.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\BdRegistre.mdb;Jet OLEDB:Database Password=onohio;"
 
    Dim D As String, A As String, B As String, SVG As String
    Dim RK As Recordset
    Set RK = New Recordset
    RK.Open "SELECT * FROM BD", ConnRegistre
    If RK!CheminBd = "" Or RK!CheminUtil = "" Or IsNull(RK!CheminBd) Or IsNull(RK!CheminUtil) Then GoTo EndLine
    If Dir(RK!CheminBd, vbHidden) = "" Or Dir(RK!CheminUtil, vbHidden) = "" Then GoTo EndLine
    D = ConnRegistre
    A = CONN
    B = CNX
 
    If D = "" Or A = "" Or B = "" Then GoTo EndLine
    Set bConnSecurite = New Connection
    Set bConnSecurite = CNX
 
    Set bConnActive = New Connection
    Set bConnActive = CONN
 
    Set bConnShape = New Connection
    Set bConnShape = ConnShape
 
    SVG = BASE_DE_DONNEES_ACTIVE
    CheminSon = App.Path & "\SON\"
    Screen.MousePointer = 11
    SPLASH.Show
    Exit Sub
EndLine:
    If Dir(App.Path & "\BdRegistre.mdb", vbHidden) = "" Then
        JouerSon CheminSon & "malfound.wav"
        MsgBox "Le fichier de démarrage est manquant.", , "Echec de démarrage"
        End
        Exit Sub
    End If
 
    If A = "" Or B = "" Or D = "" Then
        JouerSon CheminSon & "malfound.wav"
        Dim RPO
        RPO = MsgBox("La base de données active a été deplacée ou abimée." & vbLf & "Dans le premier cas, localisez la sinon restaurez la dernière sauvegarde." & vbLf & "Voulez-vous localiser la base de données?", vbYesNo + vbQuestion + vbDefaultButton1, "WAPO")
        If RPO = vbNo Then Exit Sub
        z_CONNEXION.Show
        z_CONNEXION.Visible = False
'        z_CONNEXION.CommonDialog1.CancelError = True
        '...Définit la propriété Flags
        z_CONNEXION.CommonDialog1.Flags = cdlOFNHideReadOnly
        '...Définit les filtres
        z_CONNEXION.CommonDialog1.Filter = "Fichier base de données (*.mdb,*.dbf,*.mdf)|*.mdb;*.dbf;*.mdf"
        '...Définit le filtre par défaut
    '               feuille_mere.CommonDialog1.FilterIndex = 1
        '...Affiche la boîte de dialogue Ouverture
        z_CONNEXION.CommonDialog1.InitDir = "C:\LOGICIELS DE GESTION HI\COOPERATIVE AGRICOLE"
        z_CONNEXION.CommonDialog1.ShowOpen
        '...Récupérer le nom du fichier sélectionné
 
        Set RK = New Recordset
        RK.Open "SELECT * FROM BD", ConnRegistre
        Dim CH As String
 
        If z_CONNEXION.CommonDialog1.FileName = "" Then
            CH = RK!CheminBd
          Else
            CH = z_CONNEXION.CommonDialog1.FileName
        End If
 
        RK.Close
        Set RK = Nothing
 
        ConnRegistre.Execute "UPDATE BD Set CheminBd='" & CH & "'"
        Set bConnActive = New Connection
        Set bConnActive = CONN
        Set RK = New Recordset
        RK.Open "SELECT RepereWAPO FROM SOCIETE", bConnActive
        Dim CheminUtil As String
        CheminUtil = ExtractFilePath(CH) & "\bdSecurite." & ExtractFileExt(CH)
        If (Dir(CheminUtil) <> "") Then ConnRegistre.Execute "UPDATE BD Set CheminUtil='" & CheminUtil & "'"
        Beep
        MsgBox "WAPO va se fermer.", , "WAPO"
        Screen.MousePointer = 0
        End
    End If
 
    Exit Sub
GestErr:
    If Err.Description Like "Aucune valeur donnée pour*" Then
        MsgBox "La base de données selectionnée n'est pas au bon format." & vbLf & "Veuillez en choisir une autre.", , "WAPO"
        ConnRegistre.Execute "UPDATE BD Set CheminBd='" & SVG & "'"
        End
    End If
 
    If Err.Description Like "Format de base de données*non reconnu." Then
        Dim RP
        Beep
        RP = MsgBox("Le format de la base de données active n'est pas reconnu. Votre base de données est surement abîmée." & vbLf & "Voulez-vous restaurer la dernière sauvegarde de la base de données?", vbYesNo + vbQuestion + vbDefaultButton2, "WAPO")
        If RP = vbNo Then Exit Sub
        Dim SCE As String
        SCE = ExtractFilePath(BASE_DE_DONNEES_ACTIVE) & "\SAUVEGARDE\" & ExtractFileName(BASE_DE_DONNEES_ACTIVE)
        CopyFile SCE, BASE_DE_DONNEES_ACTIVE, False
        Main
    End If
 
    If Err.Description = "Nom ou numéro de fichier incorrect" Then
        GoTo EndLine
      Else
        GestionDesErreurs "Echec de demarrage", CheminSon & "malfound.wav"
    End If
End Sub
 
Public Function AjouterSecurite(F As String) As Boolean
    AjouterSecurite = True
    If ProfilUtilisateur = "CONSTRUCTEUR" Or ProfilUtilisateur = "ADMINISTRATEUR" Then Exit Function
    Dim RK As New Recordset
    RK.Open "Select * From FICHIER WHERE (Matricule='" & MleUtilisateur & "') and (Fichier='" & F & "') and (Ajouter=True)", bConnSecurite
    If RK.EOF Then AjouterSecurite = False
    RK.Close
    Set RK = Nothing
    Screen.MousePointer = 0
End Function
 
Public Function ModifierSecurite(F As String) As Boolean
    ModifierSecurite = True
    If ProfilUtilisateur = "CONSTRUCTEUR" Or ProfilUtilisateur = "ADMINISTRATEUR" Then Exit Function
    Dim RK As New Recordset
    RK.Open "Select * From FICHIER WHERE (Matricule='" & MleUtilisateur & "') and (Fichier='" & F & "') and (Modifier=True)", bConnSecurite
    If RK.EOF Then ModifierSecurite = False
    RK.Close
    Set RK = Nothing
    Screen.MousePointer = 0
End Function
 
Public Function SupprimerSecurite(F As String) As Boolean
    SupprimerSecurite = True
    If ProfilUtilisateur = "CONSTRUCTEUR" Or ProfilUtilisateur = "ADMINISTRATEUR" Then Exit Function
    Dim RK As New Recordset
    RK.Open "Select * From FICHIER WHERE (Matricule='" & MleUtilisateur & "') and (Fichier='" & F & "') and (Supprimer=true)", bConnSecurite
    If RK.EOF Then SupprimerSecurite = False
    RK.Close
    Set RK = Nothing
    Screen.MousePointer = 0
End Function
 
Public Function ImprimerSecurite(F As String) As Boolean
    ImprimerSecurite = True
    If ProfilUtilisateur = "CONSTRUCTEUR" Or ProfilUtilisateur = "ADMINISTRATEUR" Then Exit Function
    Dim RK As New Recordset
    RK.Open "Select * From FICHIER WHERE (Matricule='" & MleUtilisateur & "') and (Fichier='" & F & "') and (Imprimer=True)", bConnSecurite
    If RK.EOF Then ImprimerSecurite = False
    RK.Close
    Set RK = Nothing
    Screen.MousePointer = 0
End Function
 
Public Sub WRITE_JOURNAL(Tache As String, CIBLE As String, IND As Variant)
    If ProfilUtilisateur = "CONSTRUCTEUR" Or ProfilUtilisateur = "ADMINISTRATEUR" Then Exit Sub
    REFERENCE_SECURITE = NUMERO_AUTO
    bConnSecurite.Execute "Insert Into JOURNAL (Ref,Tache,DM,TM,Cible,Indice,Matricule) Values ('" & REFERENCE_SECURITE & "','" & Tache & "','" & Date & "','" & Time & "','" & CIBLE & "','" & IND & "','" & MleUtilisateur & "')"
End Sub
 
Public Sub JOURNAL_MODIFICATION(Champ As String, AV As Variant, NV As Variant)
    If ProfilUtilisateur = "CONSTRUCTEUR" Or ProfilUtilisateur = "ADMINISTRATEUR" Then Exit Sub
    bConnSecurite.Execute "Insert Into JOURNAL_DES_MODIFICATIONS (Ref,Champ,AncienneValeur,NouvelleValeur) Values ('" & REFERENCE_SECURITE & "','" & Champ & "','" & AV & "','" & NV & "')"
End Sub
 
Public Function AUTRE_SOURCE_DE_DONNEES() As Boolean
    Dim RK As Recordset
    Set RK = New Recordset
    RK.Open "SELECT Asd FROM BD", ConnRegistre
 
    If RK!Asd = True Then
        AUTRE_SOURCE_DE_DONNEES = True
      Else
        AUTRE_SOURCE_DE_DONNEES = False
    End If
 
    RK.Close
    Set RK = Nothing
End Function
 
Public Function BASE_DE_DONNEES_ACTIVE() As String
    Dim RK As New Recordset
    RK.Open "SELECT * FROM BD", ConnRegistre
    BASE_DE_DONNEES_ACTIVE = RK!CheminBd
    RK.Close
    Set RK = Nothing
End Function
 
Public Function BASE_DE_DONNEES_SECURITE() As String
    Dim RK As New Recordset
    RK.Open "SELECT * FROM BD", ConnRegistre
    BASE_DE_DONNEES_SECURITE = RK!CheminUtil
    RK.Close
    Set RK = Nothing
End Function
 
Private Function NUMERO_AUTO() As String
    Dim RK As New Recordset
    RK.Open "Select Max(Val(Ref)) As R from JOURNAL", bConnSecurite
 
    If IsNull(RK!R) Then
        NUMERO_AUTO = "1"
      Else
        If RK.EOF Then
            NUMERO_AUTO = "1"
          Else
            NUMERO_AUTO = RK!R + 1
        End If
    End If
 
    RK.Close
    Set RK = Nothing
End Function
 
Public Function CONN() As Connection
    Set CONN = New Connection
    CONN.CursorLocation = adUseClient
    CONN.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & BASE_DE_DONNEES_ACTIVE & ";Jet OLEDB:Database Password=onohio;"
End Function
 
Public Function CNX() As Connection
    Set CNX = New Connection
    CNX.CursorLocation = adUseClient
    CNX.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & BASE_DE_DONNEES_SECURITE & ";Jet OLEDB:Database Password=onohio;"
End Function
 
Public Function ConnShape() As Connection
    Set ConnShape = New Connection
    ConnShape.CursorLocation = adUseClient
    ConnShape.Open "PROVIDER=MSDataShape;Data PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & BASE_DE_DONNEES_ACTIVE & ";Jet OLEDB:Database Password=onohio;"
End Function
 
Public Function ANNEE() As String
    ANNEE = ""
    Dim RK As New Recordset
    RK.Open "SELECT Annee FROM c_PERIODE_DE_CAMPAGNE ORDER BY Annee DESC", bConnActive
    If RK.EOF = False Then ANNEE = RK!ANNEE
    RK.Close
    Set RK = Nothing
End Function
 
Public Sub ACTUALISER_STOCK(bDebut As Date, bFin As Date)
    bConnActive.Execute "DELETE * FROM z_STOCK"
    bDebut = Format(bDebut, "mm/dd/yyyy")
    bFin = Format(bFin, "mm/dd/yyyy")
    bConnActive.Execute "INSERT INTO z_STOCK (NumeroAchat,NomProduit,Entree) SELECT NumeroAchat,NomProduit,Sum(Poids) As P FROM f_ACHAT WHERE (DateAchat BETWEEN #" & bDebut & "# AND #" & bFin & "#) GROUP BY NomProduit,NumeroAchat"
    bConnActive.Execute "INSERT INTO z_STOCK (NumeroAchat,NomProduit,Sortie) SELECT NumeroAchat,NomProduit,Sum(Poids) As P FROM f_VENTE_FILS INNER JOIN f_VENTE_PARENT ON f_VENTE_FILS.NumeroVente=f_VENTE_PARENT.NumeroVente WHERE (DateVente BETWEEN #" & bDebut & "# AND #" & bFin & "#) GROUP BY NomProduit,NumeroAchat"
End Sub

Edit :
je crois savoir par la recherche que le problème doit se poser sur la version des fichiers dll et ocx à l'installation. ils doivent surement périmés. la question est de savoir où trouver les fichiers récents.