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
Cet article est régulièrement mis à jour par des experts sous la direction de Jean-François Pillou, fondateur de CommentCaMarche et directeur délégué au développement numérique du groupe Figaro.
