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
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
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
Edit :
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
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.
Partager