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