Interrompre l'exécution d'un code

**pgz** · 04/05/2006, 21h14

Bonsoir,

J'effectue une recherche assez longue parfois dans des dossiers. J'utilise une progressbar pour afficher l'avancement de la tâche.
Y a-t-il un moyen d'interrompre la recherche sur demande de l'opérateur, par exemple par click sur un bouton 'Annuler'?

pgz

**Arkham46** · 04/05/2006, 21h49

slt,

J'avais le même besoin (comme beaucoup de monde je pense) :
la solution un peu basique est de mettre un doevents dans le traitement pour que les messages soient traités par l'application et dans l'événement click du bouton tu mets à Vrai une variable globale (qui avait été mise à Faux au début du traitement)
-> lorsque la variable est Vrai tu sors de ta boucle

Mais c'est ennuyant avec DoEvents parce que l'utilisateur peut faire n'importe quoi : fermer le formulaire, lancer un autre traitement, modifier des données, ...
Il faut alors tester un peu partout la valeur de la variable précédente pour refuser l'action ou désactiver les contrôles si le traitement est en cours.
Il faut également mieux que le formulaire soit modal pour interdire de passer sur un autre formulaire en cours de traitement.

Donc j'ai cherché une solution et j'en suis arrivé à un "petit" module que voilà :

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
Option Compare Database
Option Explicit
'************************************************************************************************************
'   Fonction de remplacement du DoEvents
'   N'autorise que le click sur un bouton particulier
'   Annule les autres événements clavier et souris
'************************************************************************************************************
' Lecture file des messages
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
' Traduit le message
Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
' Envoie le message
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
' lit la position du curseur
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Charge un cursor
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
' Défini le curseur
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Const IDC_HAND = 32649 ' Curseur Main
Private Const HT_CAPTION = 2 ' Barre de titre
Private Const HTMINBUTTON = 8 ' Bouton minimiser
Private Const HTMAXBUTTON = 9 ' Bouton maximiser
Private Const HTCLOSE = 20 ' Bouton fermer
Private Const WM_LBUTTONDOWN = &H201 ' Click gauche
Private Const WM_NCLBUTTONDOWN = &HA1 ' Click gauche sur barre de titre
Private Const WM_NCLBUTTONUP = &HA2 ' Click gauche sur barre de titre
Private Const PM_REMOVE = &H1 ' Supprime le message lu
Private Const WM_MOUSEFIRST = &H200 ' Premier message souris
Private Const WM_MOUSELAST = &H209 ' Dernier message souris
Private Const WM_KEYFIRST = &H100 ' Premier message clavier
Private Const WM_KEYLAST = &H108 ' Dernier message clavier
' Type point pour API
Public Type POINTAPI
    x As Long
    y As Long
End Type
' Type message pour API
Public Type MSG
    hWnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type
 
'*******************************************************************************
' Renvoie Vrai si on a cliqué sur le contrôle pCtrl
' Les autres messages clavier et souris sont annulés
'*******************************************************************************
' pForm : Formulaire
' pCtrl : Contrôle qui doit rester activé
' pAllowMove : Autorise le déplacement du formulaire
' pAllowMinimize : Autorise la réduction du formulaire
' pAllowMaximize : Autorise l'agrandissement du formulaire
' pAllowClose : Autorise la fermeture du formulaire
'*******************************************************************************
Public Function CheckClick(pForm As Access.Form, pCtrl As Access.Control, Optional pAllowMove As Boolean, Optional pAllowMinimize As Boolean, Optional pAllowMaximize As Boolean, Optional pAllowClose As Boolean) As Boolean
    On Error GoTo gestion_erreurs
    Dim lmsg As MSG
    Dim lp As POINTAPI
    Dim lx As Long, ly As Long, lw As Long, lh As Long
    Dim hCur As Long
    Dim lOldMousePointer As Long
    ' Ancien pointeur de la souris
    lOldMousePointer = Screen.MousePointer
    ' Position du contrôle sur l'écran
    pCtrl.accLocation lx, ly, lw, lh
    ' Recherche de message souris sur le formulaire (les messages lus sont supprimés)
    While PeekMessage(lmsg, pForm.hWnd, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) <> 0
        ' Vérifie si la souris est sur le contrôle
        If lmsg.pt.x > lx And lmsg.pt.x < (lx + lw) And lmsg.pt.y > ly And lmsg.pt.y < (ly + lh) Then
            ' Envoie le message
            TranslateMessage lmsg
            DispatchMessage lmsg
            ' Vérifie si on a cliqué sur le contrôle
            If lmsg.message = WM_LBUTTONDOWN Then CheckClick = True
        End If
    Wend
    ' Recherche de message click sur la barre de titre(les messages lus sont supprimés)
    While PeekMessage(lmsg, pForm.hWnd, WM_NCLBUTTONDOWN, WM_NCLBUTTONUP, PM_REMOVE) <> 0
        ' Vérifie si le message doit être envoyé
        If (pAllowMove And lmsg.wParam = HT_CAPTION) Or (pAllowMinimize And lmsg.wParam = HTMINBUTTON) Or _
           (pAllowMaximize And lmsg.wParam = HTMAXBUTTON) Or (pAllowClose And lmsg.wParam = HTCLOSE) Then
            ' Envoie le message
            TranslateMessage lmsg
            DispatchMessage lmsg
        End If
    Wend
    ' Supprime les messages clavier sur le formulaire
    While PeekMessage(lmsg, pForm.hWnd, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) <> 0
    Wend
    ' Supprime les messages souris sur l'application
    While PeekMessage(lmsg, Application.hWndAccessApp, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) <> 0
    Wend
    ' Supprime les messages clavier sur l'application
    While PeekMessage(lmsg, Application.hWndAccessApp, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) <> 0
    Wend
    ' Lit la position du curseur
    GetCursorPos lp
    ' Vérifie si la souris est sur le contrôle
    If lp.x > lx And lp.x < (lx + lw) And lp.y > ly And lp.y < (ly + lh) Then
        ' Change le curseur en Main lorsqu'on survole le contrôle
        hCur = LoadCursor(0, IDC_HAND)
        If (hCur > 0) Then
            lOldMousePointer = Screen.MousePointer
            SetCursor hCur
        End If
    Else
        ' Rétablit le curseur d'origine si on quitte le contrôle
        Screen.MousePointer = lOldMousePointer
    End If
gestion_erreurs:
    If Err.Number <> 0 Then MsgBox Err.Description
End Function

La fonction renvoie Vrai si on a cliqué sur le bouton passé en paramètre.
Elle annule tous les autres événements souris et clavier (ça évite que tout s'enchaîne lorsque l'utilisateur récupère la main), sauf éventuellement le déplacement du formulaire et les click sur les boutons systèmes s'ils sont autorisés dans les paramètres.
Comme ça l'utilisateur ne peut rien faire d'autre que d'attendre ou de cliquer sur le bouton prévu.
En bonus le curseur change quand on survol le bouton.
Et il suffit d'un Me.Repaint sur le formulaire pour mettre à jour l'affichage qui indique la progression.

Un exemple d'utilisation avec :
- BtnStart : le bouton qui lance le traitement
- BtnStop : le bouton qui stoppe le traitement (il n'est pas nécessaire de mettre quelque chose dans son événement "sur click")
- EtqCompteur : une étiquette pour indiquer où en est le traitement

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
Private Sub BtnStart_Click()
Dim i As Long, j As Long
Dim s As String
' Sablier On
DoCmd.Hourglass True
' Boucle de traitement
For i = 1 To 1000
    ' Effectue un traitement quelconque...
    For j = 1 To 10000
        s = right(left(Mid(Now, 1, 4), 3), 1)
    Next
    '
    ' Etiquette indiquant le compteur
    Me.EtqCompteur.Caption = i
    ' Rafraîchi l'affichage
    Me.Repaint
    ' Vérifie si on clique sur le bouton d'arrêt
    ' On autorise le déplacement du formulaire
    If CheckClick(Me, Me.BtnStop, True) Then
        ' Confirmation de l'arrêt
        If MsgBox("Arrêter le traitement", vbInformation Or vbYesNo) = vbYes Then Exit For
    End If
Next
' Sablier Off
DoCmd.Hourglass False
End Sub

Je précise que j'utilise une fonction non documentée : AccLocation pour connaître la position du bouton sur l'écran. Si on ne veut pas utiliser de fonction non documentée on peut s'en passer mais on n'a alors plus la possibilité de savoir où on a cliqué sur le formulaire.
Et je précise également que j'ai fais ce code hier soir, il n'a été testé que par moi.

Si quelqu'un a plus simple, ou un bout de code qui fait moins peur, je suis preneur, j'aurai juste fais tout ça pour rien.

Bye.

**pgz** · 05/05/2006, 15h58

Bonjour,

la solution un peu basique est de mettre un doevents dans le traitement pour que les messages soient traités par l'application et dans l'événement click du bouton tu mets à Vrai une variable globale (qui avait été mise à Faux au début du traitement)
-> lorsque la variable est Vrai tu sors de ta boucle

C'est exactement ce que j'ai essayé de faire, mais sans aucun succès. Je n'ai obtenu aucun résultat parce qu'apparemment l'évènement 'sur click' ne se déclenche jamais

. J'ai pensé que c'était normal

. Avec ce que tu en dit, je vais essayer de nouveau cela pour comprendre...

Donc j'ai cherché une solution et j'en suis arrivé à un "petit" module que voilà :

Cela m'ouvre qq espaces que je vais m'empresser d'explorer.

à Arkham46

, qui s'est vraiment sorti les doigts, et je reviendrai conclure dès que j'aurai une appli qui marche.

pgz

**pgz** · 05/05/2006, 17h39

Re,

Dans le contexte de mon pb actuel, la solution 'basique' me convient. La progressbar est un formulaire sans bordure, sans bouton (min/max, Fermer, aide), ouvert dans une fenêtre modale indépendante. On ne peut même pas fermer accidentellement ce formulaire. Le seul bouton actionnable est celui que j'ai prévu : 'Annuler'.

Je garde la fonction AccLocation pour des contextes moins faciles.

Merci.

pgz

Interrompre l'exécution d'un code

VBA Access

Discussions similaires

Partager

Partager