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