VBA - Message pour faire patienter l'utilisateur
Petite application pour afficher un message d'attente quand un processus est relativement long.
Et en annexe enlever le cadre de l'userForm
Introduction
Un message "défilant" et une icône "animée" sont disponibles.
- Message et icône fixes
- Message défilant et icône mobile
Toutes les propriétés sont paramétrables.
- Deux commandes..
- Démarrer > sablier.Show vbModeless
- Arrêter > Animer = False
- Trois propriétés..
- Le texte qui défile > TxtLab = "Le texte qui défile" (par exemple)
- Vitesse de l'image > VitesseS = 3500 par défaut = 3500
- Vitesse du texte > VitesseT = 1000 par défaut = 1000
- Empêcher l'icône de tourner > VitesseS = -1
- Empêcher le texte de défiler > VitesseT = -1
Pour changer d'image il faut avoir une image Gif décomposée et
Changer ou ajouter une ListImage avec vos images.
Il faut aussi modifier la Const NbImage en fonction du nombre
d'images qu'il y aura dans votre ListImage.
L'UserForm
Dans UserForm nommer Sablier
Option Explicit Dim TempsS As Long Dim TempsT As Long Dim NumImg As Byte Dim LG3 As Integer Dim Deb As Integer Private Sub UserForm_Activate() Animation End Sub Private Sub UserForm_Initialize() '------------------------------------------------------------------ 'Les données par défaut If TxtLab = "" Then TxtLab = "Traitement en cour, veuillez patienter svp..." End If If VitesseS = 0 Then VitesseS = 3500 End If If VitesseT = 0 Then VitesseT = 1000 End If '------------------------------------------------------------------ OteTitleBarre Me.Caption, False Me.Height = 43 NumImg = 1 ImgSablier.Picture = ListSablier.ListImages(NumImg).Picture LabSablier.Caption = TxtLab LG3 = LabSablier.Width Animer = True End Sub Sub Animation() While Animer If VitesseS <> -1 Then TempsS = TempsS + 1 If TempsS = VitesseS Then TempsS = 0 NumImg = NumImg + 1: If NumImg > NbImage Then NumImg = 1 ImgSablier.Picture = ListSablier.ListImages(NumImg).Picture End If End If If VitesseT <> -1 Then TempsT = TempsT + 1 If TempsT = VitesseT Then TempsT = 0 If Abs(Deb) > LG3 Then Deb = Frame1.Width LabSablier.Left = Deb Deb = Deb - 1 End If End If DoEvents Wend Unload Me End Sub
Le module public
Option Explicit 'Mettre à false pour fermer l'UF Public Animer As Boolean 'Le texte qui défile dans l'UF, Public TxtLab As String 'Pour adapter la vitesse de défilement du sablier Public VitesseS As Integer 'Pour adapter la vitesse de défilement du texte Public VitesseT As Integer Public Const NbImage = 12 '---------------------------------------------------------------- 'Pour enlever la barre de titre du UF Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Const GWL_STYLE = (-16) Const WS_CAPTION = &HC00000 Const SWP_FRAMECHANGED = &H20 Public Declare Function FindWindowA Lib "user32" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Public Declare Function GetWindowRect Lib "user32" _ (ByVal hwnd As Long, lpRect As RECT) As Long Public Declare Function GetWindowLong Lib "user32" Alias _ "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias _ "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Public Declare Function SetWindowPos Lib "user32" _ (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, _ ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, _ ByVal wFlags As Long) As Long Public Type POINTAPI X As Long Y As Long End Type Public m_CursorPos As POINTAPI Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long Public Afficher As Boolean Sub OteTitleBarre(stCaption As String, pbVisible As Boolean) Dim vrWin As RECT Dim style As Long Dim lHwnd As Long '- Recherche du handle de la fenêtre par son Caption lHwnd = FindWindowA(vbNullString, stCaption) If lHwnd = 0 Then MsgBox "Handle de " & stCaption & " Introuvable", vbCritical Exit Sub End If GetWindowRect lHwnd, vrWin style = GetWindowLong(lHwnd, GWL_STYLE) If pbVisible Then SetWindowLong lHwnd, GWL_STYLE, style Or WS_CAPTION Else SetWindowLong lHwnd, GWL_STYLE, style And Not WS_CAPTION End If SetWindowPos lHwnd, 0, vrWin.Left, vrWin.Top, vrWin.Right - vrWin.Left, _ vrWin.Bottom - vrWin.Top, SWP_FRAMECHANGED End Sub
Exemple d'emploi
Sur une feuille Excel, deux boutons.
Dans le module de la feuille.
Private Sub CommandButton1_Click() 'Démarrer Sablier.Show vbModeless End Sub Private Sub CommandButton2_Click() 'Terminer Animer = False End Sub
Téléchargement
Vous pouvez télécharger Le classeur exemple Sablier.xls
Ce document intitulé « VBA - Message pour faire patienter l'utilisateur » issu de Comment Ça Marche (www.commentcamarche.net) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.