[A-02] ma base de donnée plante

**xycoco** · 26/11/2008, 09h15

Bonjour,

Je ne sais pas si je suis dans la bonne section pour poser mon problème.

Ma base de donnée bug dès que je clic sur un bouton. Elle se ferme d'un seul coup. Le fichier "mabd.ldb" est toujours présent.

Le code du bouton :

Code :

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

1
2
3
4
5
6
7
8
9
Private Sub btnOuvrirExplorateur_Click()
    Dim nom As String
    Dim MonCritere As String
    nom = "Q:\Coco\Livre de Cave\Bouteille"
    MonCritere = OuvrirUnFichier(Me.hwnd, "Sélectionner une image", 1, , , nom)
    DoCmd.SetWarnings False
    DoCmd.RunSQL "INSERT INTO tbl_Bouteille ( Nom, ImageBouteille ) SELECT """ & MonCritere & """, """ & MonCritere & """;"
    Form_Load
End Sub

Apparemment le problème survient lorsque je rappelle la fonction Form_Load

Il s'agit d'un formulaire sur lequel je travaille avec une classe ClImages. J'utilise un bouton qui ouvre l'explorateur pour pouvoir incrémenté mon formulaire d'un image supplémentaire.

L'ensemble du code du formulaire:

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
Option Compare Database
Option Explicit
 
Private Declare Sub PathStripPath Lib "shlwapi.dll" Alias "PathStripPathA" (ByVal pszPath As String)
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
                   "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
 
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
 
Private Declare Sub MouseWheelHook Lib "MouseWheelDVPNoReg.dll" _
         (ByVal pHwnd As Long, ByVal pScrollForm As Boolean)
Private Declare Sub MouseWheelUnHook Lib "MouseWheelDVPNoReg.dll" _
         (ByVal pHwnd As Long)
 
'***************************************************************************************
'*                               Démo Menu avec Images                                 *
'***************************************************************************************
 
Private climg As ClImage    ' Classe Image
 
Private Const cEspaceX As Long = 100    ' Espacement X entre les vignettes
Private Const cEspaceY As Long = 100    ' Espacement Y entre les vignettes
 
Private gTaille As Long   ' Taille de chaque vignette
Private gImages As New Collection    ' Collection pour conserver les coordonnées de chaque image
Private gExplMAJ As Boolean     ' Flag pour réinitialisation de l'explication
Private Const cType As Integer = acOLESizeZoom    ' Type d'affichage des vignettes
Private Const cPosition As Integer = 2   ' Position des vignettes
 
Private Sub btnFermer_Click()
    On Error Resume Next
    DoCmd.Close acForm, Me.Name
    If Err.Number <> 0 Then MsgBox Err.description
End Sub
Private Sub btnOuvrirExplorateur_Click()
    Dim nom As String
    Dim MonCritere As String
    nom = "Q:\Coco\Livre de Cave\Bouteille"
    MonCritere = OuvrirUnFichier(Me.hwnd, "Sélectionner une image", 1, , , nom)
    DoCmd.SetWarnings False
    DoCmd.RunSQL "INSERT INTO tbl_Bouteille ( Nom, ImageBouteille ) SELECT """ & MonCritere & """, """ & MonCritere & """;"
    Form_Load
End Sub
 
'---------------------------------------------------------------------------------------
' Sur Fermeture du formulaire
'---------------------------------------------------------------------------------------
Private Sub Form_Close()
' Récative Thèmes XP
    If SysCmd(acSysCmdAccessVer) = "11.0" Then climg.SetXPTheme True
    ' On libère les classes
    If Not climg Is Nothing Then Set climg = Nothing
End Sub
Private Sub Form_Load()
    MouseWheelHook Me.hwnd, True
    Dim lFormCadreLeftOld As Long
    Dim lCtrl As Variant
    On Error GoTo Gestion_Erreurs
    ' Initialise la classe
    Set climg = New ClImage
    ' Centre les contrôles horizontalement
    On Error Resume Next
    On Error GoTo Gestion_Erreurs
    ' Pas de menu sur bouton droit
    Me.ShortcutMenu = False
    ' Désactive thème XP
    If SysCmd(acSysCmdAccessVer) = "11.0" Then climg.SetXPTheme False
    ' Initialise le contrôle image
    climg.SetImgCtrl Me.Image0
    ' Remplit l'image de blanc
    climg.FillColor Me.Section(acDetail).BackColor
    ' Applique l'image (blanche) dans le contrôle
    climg.Repaint
    ' Taille Vignettes
    gTaille = climg.PixelToTwipsX("160")
    ' Affiche le menu
    DisplayMenu
    ' Applique les changements sur le contrôle image
    climg.Repaint
Gestion_Erreurs:
    If Err.Number <> 0 Then MsgBox Err.description
End Sub
 
'---------------------------------------------------------------------------------------
' Affiche le menu
'---------------------------------------------------------------------------------------
Private Sub DisplayMenu()
    Dim rs As dao.Recordset
    Dim lX As Long
    Dim lY As Long
    Dim lTexteHeight As Long
    Dim lCalcHeight As Long
    On Error GoTo Gestion_Erreurs
    ' Désactive l'affichage du formulaire
    Me.Painting = False
    ' Curseur d'attente (horloge)
    DoCmd.Hourglass True
    ' Rempli l'image de blanc
    climg.FillColor Me.Section(acDetail).BackColor
    ' Table des entrées de menu
    Set rs = CurrentDb.OpenRecordset("select * from tbl_Bouteille order by Nom")
    ' On se place sur le premier enregistrement
    rs.MoveFirst
    ' On laisse un tiers d'espace vertical avant de commencer à dessiner
    lY = cEspaceY / 3
    ' On parcourt la table tbl_Bouteille
    While Not rs.EOF
        ' Retour à la ligne si on dépasse l'image à droite
        If lX + cEspaceX + gTaille > Me.Image0.Width Then
            lX = 0
            lY = lY + cEspaceY + gTaille + lTexteHeight
            lTexteHeight = 0
        End If
        ' Police de caractères
        climg.DrawNewFont climg.FontSizeToHeight(10) * climg.TwipsToPixelX(gTaille) / 140, 0, 700, False, False, False, "Comic Sans MS"
        ' Taille du texte pour contenir deux lignes
        climg.GetTextLength rs!nom, gTaille + cEspaceX, lCalcHeight, True
        If lCalcHeight > lTexteHeight Then lTexteHeight = lCalcHeight
        lX = lX + cEspaceX
        ' Agrandi l'image si nécessaire
        If lY + gTaille + lTexteHeight > Image0.Height Then
            climg.ImgResize Image0.Width, climg.fMax(lY + gTaille + lTexteHeight, Image0.Height), , , Me.Section(acDetail).BackColor
        End If
        ' Ajoute une image à la liste, de largeur cTaille
        climg.ImageListAdd rs!nom, rs!ImageBouteille, gTaille
        ' Dessine l'image en noir et blanc
        ' et ajoute une region correspondant à l'image avec le nom du formulaire en identifiant
        climg.PaintImage rs!nom, lX, lY, lX + gTaille, lY + gTaille, Me.Section(acDetail).BackColor, cType, cPosition, , , "GRAY", , , rs!nom
        ' Police de caractères
        climg.DrawNewFont climg.FontSizeToHeight(10) * climg.TwipsToPixelX(gTaille) / 140, 0, 700, False, False, False, "Comic Sans MS"
        ' Affiche le texte sous l'image
        climg.DrawText rs!nom, lX - cEspaceX / 2, lY + gTaille, lX + gTaille + cEspaceX / 2, lY + gTaille + lCalcHeight, , , , , True
        ' Stocke les coordonnées de l'image
        gImages.Add Array(lX, lY), rs!nom
        ' On avance d'une image vers la droite
        lX = lX + gTaille
        ' Et on avance d'un enregistrement
        rs.MoveNext
    Wend
    ' Dessin définitif dans le contrôle
    climg.Repaint
    ' Conserve le menu de base avec les photos en noir et blanc
    climg.KeepImgData "Tampon"
    ' Referme le recordset
    rs.Close
    Set rs = Nothing
Gestion_Erreurs:
    ' Réactive l'affichage du formulaire
    Me.Painting = True
    ' Si l'image existe déjà dans gImages on la supprime et on recommence
    If Err.Number = 457 Then gImages.Remove rs!nom: Resume
 
 
    DoCmd.Hourglass False    ' Réinitialisation du curseur
    If Err.Number <> 0 Then MsgBox Err.description
End Sub
 
Private Sub Form_Open(Cancel As Integer)
DoCmd.Restore
End Sub
 
Private Sub Image0_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim sRegion As String    ' Région  sur laquelle on a cliqué
    On Error GoTo Gestion_Erreurs
    If Not climg Is Nothing Then    ' On vérifie que la classe est initialisée
        If Button = acLeftButton Then
            sRegion = climg.GetMouseRegion(X, Y)  ' On récupère la région sous le curseur de la souris
            If sRegion <> "" Then
                ' Ouvre le formulaire correspondant
                On Error Resume Next
                If CurrentProject.AllForms("frm_Bouteille").IsLoaded Then
                Forms![frm_Bouteille]![NomBouteille].Value = sRegion
                Forms![frm_Bouteille]![NomBouteille].Refresh
                Forms![frm_Bouteille]![imgBouteille].Picture = Forms![frm_Bouteille]![ImageBouteille].Value
                Forms![frm_Bouteille]![imgBouteille].Refresh
                Forms![frm_Bouteille].ImageBouteille_AfterUpdate
                Else
                If CurrentProject.AllForms("frm_BouteilleNouveau").IsLoaded Then
                Forms![frm_BouteilleNouveau]![NomBouteille].Value = sRegion
                Forms![frm_BouteilleNouveau]![NomBouteille].Refresh
                Forms![frm_BouteilleNouveau]![imgBouteille].Picture = Forms![frm_BouteilleNouveau]![ImageBouteille].Value
                Forms![frm_BouteilleNouveau]![imgBouteille].Refresh
                Forms![frm_BouteilleNouveau].ImageBouteille_AfterUpdate
                End If
                End If
                If Err.Number <> 0 Then
                    DoCmd.OpenReport sRegion, acViewPreview
                    If Err.Number = 0 Then
                        Me.Visible = False
                        DoCmd.SelectObject acReport, sRegion
                    End If
                End If
                On Error GoTo Gestion_Erreurs
            End If
        End If
    End If
Gestion_Erreurs:
    If Err.Number <> 0 Then MsgBox Err.description
End Sub
'---------------------------------------------------------------------------------------
' Sur déplacement de la souris
'---------------------------------------------------------------------------------------
' Modifie le curseur et encadre de rouge l'image survolée par la souris
'---------------------------------------------------------------------------------------
Private Sub Image0_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim sRegion As String    ' Région sous le curseur
    Static OldRegion As String    ' Région lors du précédent appel de cette fonction
    On Error GoTo Gestion_Erreurs
    If Not climg Is Nothing Then    ' On vérifie que la classe est initialisée
        sRegion = climg.GetMouseRegion(X, Y)  ' On récupère la région sous le curseur de la souris
        ' Si la souris est sur une image on affiche un curseur en forme de main
        If sRegion <> "" Then climg.SetHandCursor Else climg.ResetCursor
    Else
        ' Si la classe a été perdue (principalement si modification du code
        '  durant l'exécution, c'est normalement inutile en production) alors on la réinitialise
        ' La mémoire occupée par l'instance précédente n'est pas libérée pour autant...
        Set climg = New ClImage
        Form_Load    ' Initialise le contrôle image
    End If
    If OldRegion <> sRegion Then    ' Si on a changé de région
        If sRegion <> "" Then
            ' Récupère le menu en noir et blanc
            climg.RefreshImgData "Tampon"
            ' Dessine l'image sous la souris en couleur
            climg.FillColor Me.Section(acDetail).BackColor, CLng(gImages.Item(sRegion)(0)), CLng(gImages.Item(sRegion)(1)), CLng(gImages.Item(sRegion)(0) + gTaille), CLng(gImages.Item(sRegion)(1) + gTaille)
            climg.PaintImage sRegion, gImages.Item(sRegion)(0), gImages.Item(sRegion)(1), gImages.Item(sRegion)(0) + gTaille, gImages.Item(sRegion)(1) + gTaille, Me.Section(acDetail).BackColor, cType, cPosition
            ' Dessine un cadre autour de la region
            climg.FrameRegion sRegion, 255, 2
            ' Applique les modification au contrôle
            climg.Repaint True
        ElseIf sRegion = "" Then
            ' Si pas de région sous le curseur on rétablit le menu en noir et blanc
            climg.RefreshImgData "Tampon"
            climg.Repaint True
        End If
    End If
    OldRegion = sRegion    ' Sauvegarde la valeur de la région survolée
Gestion_Erreurs:
    If Err.Number <> 0 Then MsgBox Err.description
End Sub
Private Function OuvrirUnFichier(handle As Long, _
                                Titre As String, _
                                TypeRetour As Byte, _
                                Optional TitreFiltre As String, _
                                Optional TypeFichier As String, _
                                Optional RepParDefaut As String) As String
Dim StructFile As OPENFILENAME
Dim sFiltre As String
    If Len(TitreFiltre) > 0 And Len(TypeFichier) > 0 Then
        sFiltre = TitreFiltre & " (" & TypeFichier & ")" & Chr$(0) & "*." & TypeFichier & Chr$(0)
    End If
sFiltre = sFiltre & "Tous (*.*)" & Chr$(0) & "*.*" & Chr$(0)
With StructFile
    .lStructSize = Len(StructFile) 'Initialisation de la grosseur de la structure
    .hwndOwner = handle 'Identification du handle de la fenêtre
    .lpstrFilter = sFiltre 'Application du filtre
    .lpstrFile = String$(254, vbNullChar) 'Initialisation du fichier '0' x 254
    .nMaxFile = 254 'Taille maximale du fichier
    .lpstrFileTitle = String$(254, vbNullChar) 'Initialisation du nom du fichier '0' x 254
    .nMaxFileTitle = 254  'Taille maximale du nom du fichier
    .lpstrTitle = Titre 'Titre de la boîte de dialogue
    .flags = OFN_HIDEREADONLY  'Option de la boite de dialogue
    If ((IsNull(RepParDefaut)) Or (RepParDefaut = "")) Then
        RepParDefaut = CurrentDb.Name
        PathStripPath (RepParDefaut)
        .lpstrInitialDir = Left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Mid$(RepParDefaut, 1, InStr(1, RepParDefaut, vbNullChar) - 1)))
        Else: .lpstrInitialDir = RepParDefaut
    End If
End With
If (GetOpenFileName(StructFile)) Then 'Si un fichier est sélectionné
    Select Case TypeRetour
      Case 1: OuvrirUnFichier = Trim$(Left(StructFile.lpstrFile, InStr(1, StructFile.lpstrFile, vbNullChar) - 1))
      Case 2: OuvrirUnFichier = Trim$(Left(StructFile.lpstrFileTitle, InStr(1, StructFile.lpstrFileTitle, vbNullChar) - 1))
    End Select
End If
End Function

Merci de votre aide

**Domi2** · 26/11/2008, 09h48

Bonjour,

Apparemment le problème survient lorsque je rappelle la fonction Form_Load

Effectivement, cela me semble peu approprié...

L'événement Sur chargement se déclenche de lui-même lors de l'ouverure d'un formulaire.

Pourquoi essayer d'y faire à nouveau appel ?

Domi2

**xycoco** · 26/11/2008, 09h57

Bonjour,

Le formulaire contient un contrôle Image (gérée à l'aide de la classe ClImages) me permettant de faire apparaitre plusieurs images. Au Form_load cela créé et met en forme mes images.

Au clic je souhaite ouvrir l'explorateur et insérer une nouvelle image : le rappelle de mon Form_Load est là pour rafraîchir mon contrôle Image.

Cordialement,

**Domi2** · 26/11/2008, 10h12

Re,

Je dirais qu'il faut rafraîchir uniquement le contrôle image...

Quel code utilises-tu dans l'événement Sur chargement pour afficher tes images ?

Domi2

**xycoco** · 26/11/2008, 10h49

J'ai trouvé....

Je dois faire appel à la fonction DisplayMenu (qui gère l'image) et non Form_load (qui appelle DisplayMenu). cf code 1er message du post

Code :

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

1
2
3
4
5
6
7
8
9
Private Sub btnOuvrirExplorateur_Click()
    Dim nom As String
    Dim MonCritere As String
    nom = "Q:\Coco\Livre de Cave\Bouteille"
    MonCritere = OuvrirUnFichier(Me.hwnd, "Sélectionner une image", 2, , , nom)
    DoCmd.SetWarnings False
    DoCmd.RunSQL "INSERT INTO tbl_Bouteille ( Nom, ImageBouteille ) SELECT """ & MonCritere & """, """ & nom & "\" & MonCritere & """;"
    DisplayMenu
End Sub

[A-02] ma base de donnée plante

IHM

Discussions similaires

Partager

Partager