[VBA] Changer le curseur de la souris
Motivation
En VBA, les options de curseurs disponibles pour les contrôles Microsoft Forms utilisés dans les UserForm (comme les boutons, lavel, frame, image, etc.) sont assez limitées. En effet, le curseur de la main, souvent utilisé pour indiquer des hyperliens, n'est pas disponible.
Je vous propose ici de voir une solution alternative pour gérer le changement de curseur de souris sur un contrôle Microsoft Forms. L'idée est d'assigner des types de curseurs spécifiques lorsque la souris survole ces contrôles à l'aide d'API window.
Caractéristiques principales :
- Compatible avec les versions 32 bits et 64 bits d'Excel.
- Détecte le déplacement de la souris sur le contrôle désigné et change le curseur en conséquence.
- Évite les mises à jour inutiles du curseur.
- Prend en charge différents types de curseurs standard tels que la flèche, le sablier, la main et d'autres.
Module de clasSE
Dans votre IDE VBA, créer le module de classe avec le code ci-dessous, et nommé le MouseCursorAdvanced
' --------------------------------------------------------------------- '
' '
' VBA MouseCursorAdvanced '
' '
' Copyright © 2024, 6i software '
' Version : 1.0.0 '
' Contact : vb20100bv@gmail.com '
' '
' --------------------------------------------------------------------- '
'
' Manages custom mouse cursor behavior when interacting with specific Microsoft Forms
' controls such as Label, CheckBox, and Frame. It allows you to assign specific cursor
' types when the mouse hovers over these controls.
'
' - Supports both 32-bit and 64-bit versions.
' - Detects when the mouse is moved over the designated control and change the cursor.
' - Prevents unnecessary cursor updates by checking if the cursor is already set.
' - Supported cursor types include standard icons like the arrow, wait, hand, and others.
''
Option Explicit
' _____________________________________________________________________________________________
'
' Windows API declarations
' _____________________________________________________________________________________________
#If VBA7 Then
' Declarations for Excel 64-bit or modern versions of VBA7 (Excel 2010 and later)
Private Declare PtrSafe Function GetCursorInfo Lib "user32" (ByRef pci As CursorInfo) As Boolean
Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As LongPtr) As LongPtr
Private Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As LongPtr) As LongPtr
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
' Declarations for 32-bit versions of Excel (before Excel 2010)
Private Declare Function GetCursorInfo Lib "user32" (ByRef pci As CursorInfo) As Boolean
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
' Set the default cursors in windows
Public Enum CursorTypes
WINDOW_ICON_ARROW = 32512
WINDOW_ICON_IBEAM = 32513
WINDOW_ICON_WAIT = 32514
WINDOW_ICON_CROSS = 32515
WINDOW_ICON_UPARROW = 32516
WINDOW_ICON_SIZE = 32640
WINDOW_ICON_ICON = 32641
WINDOW_ICON_SIZENWSE = 32642
WINDOW_ICON_SIZENESW = 32643
WINDOW_ICON_SIZEWE = 32644
WINDOW_ICON_SIZENS = 32645
WINDOW_ICON_SIZEALL = 32646
WINDOW_ICON_NO = 32648
WINDOW_ICON_HAND = 32649
WINDOW_ICON_APPSTARTING = 32650
CURSOR_TYPE_UNINITIALIZED = 0
End Enum
'Needed for GetCursorInfo
Private Type POINT
X As Long
Y As Long
End Type
'Needed for GetCursorInfo
Private Type CursorInfo
cbSize As Long
flags As Long
hCursor As LongPtr
ptScreenPos As POINT
End Type
' _____________________________________________________________________________________________
'
' Class definition
' _____________________________________________________________________________________________
Private cursor As CursorTypes
Private control As MSForms.control
Private WithEvents ctrlMSFormsLabel As MSForms.Label
Private WithEvents ctrlMSFormsCheckbox As MSForms.CheckBox
Private WithEvents ctrlMSFormsFrame As MSForms.frame
Public Sub Initialize(controlObject As MSForms.control, Optional cursorType As CursorTypes)
Set control = controlObject
cursor = IIf(IsMissing(cursor), CURSOR_TYPE_UNINITIALIZED, cursorType)
If TypeOf control Is MSForms.Label Then
Set ctrlMSFormsLabel = control
ElseIf TypeOf control Is MSForms.CheckBox Then
Set ctrlMSFormsCheckbox = control
ElseIf TypeOf control Is MSForms.frame Then
Set ctrlMSFormsFrame = control
Else
Debug.Print "[WARNING] MouseCursor::Initialize - use an uncontroled control " & control.Name & "(type: " & TypeName(control) & ")"
End If
End Sub
Private Sub ctrlMSFormsLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call callbackMouseMoved
End Sub
Private Sub ctrlMSFormsCheckbox_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call callbackMouseMoved
End Sub
Private Sub ctrlMSFormsFrame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call callbackMouseMoved
End Sub
Private Sub callbackMouseMoved()
If cursor <> CURSOR_TYPE_UNINITIALIZED Then
If Not IsCursorAlreadySet(cursor) Then
SetCursor LoadCursor(0, cursor)
Sleep 5
End If
End If
End Sub
' To check if a cursor is already set
Private Function IsCursorAlreadySet(cursorType As CursorTypes) As Boolean
Dim CursorHandle As LongPtr
#If VBA7 Then
CursorHandle = LoadCursor(0, cursorType)
#Else
CursorHandle = LoadCursor(ByVal 0&, cursorType)
#End If
Dim cursor As CursorInfo
cursor.cbSize = Len(cursor)
Dim CursorInfo As Boolean
CursorInfo = GetCursorInfo(cursor)
If Not CursorInfo Then
IsCursorAlreadySet = False
Exit Function
End If
IsCursorAlreadySet = (cursor.hCursor = CursorHandle)
End Function
Public Function GetCursorType(cursorInString As String) As CursorTypes
Select Case cursorInString
Case "WINDOW_ICON_ARROW"
GetCursorType = WINDOW_ICON_ARROW
Case "WINDOW_ICON_IBEAM"
GetCursorType = WINDOW_ICON_IBEAM
Case "WINDOW_ICON_WAIT"
GetCursorType = WINDOW_ICON_WAIT
Case "WINDOW_ICON_CROSS"
GetCursorType = WINDOW_ICON_CROSS
Case "WINDOW_ICON_UPARROW"
GetCursorType = WINDOW_ICON_UPARROW
Case "WINDOW_ICON_SIZE"
GetCursorType = WINDOW_ICON_SIZE
Case "WINDOW_ICON_ICON"
GetCursorType = WINDOW_ICON_ICON
Case "WINDOW_ICON_SIZENWSE"
GetCursorType = WINDOW_ICON_SIZENWSE
Case "WINDOW_ICON_SIZENESW"
GetCursorType = WINDOW_ICON_SIZENESW
Case "WINDOW_ICON_SIZEWE"
GetCursorType = WINDOW_ICON_SIZEWE
Case "WINDOW_ICON_SIZENS"
GetCursorType = WINDOW_ICON_SIZENS
Case "WINDOW_ICON_SIZEALL"
GetCursorType = WINDOW_ICON_SIZEALL
Case "WINDOW_ICON_NO"
GetCursorType = WINDOW_ICON_NO
Case "WINDOW_ICON_HAND"
GetCursorType = WINDOW_ICON_HAND
Case "WINDOW_ICON_APPSTARTING"
GetCursorType = WINDOW_ICON_APPSTARTING
Case "CURSOR_TYPE_UNINITIALIZED"
GetCursorType = CURSOR_TYPE_UNINITIALIZED
Case Else
GetCursorType = CURSOR_TYPE_UNINITIALIZED
End Select
End FunctionUtilisationS
Premier exemplE
Nous commencerons par ajouter les éléments suivants dans un UserForm :
- Un Label nommé Label1
- Deux CheckBoxes nommées respectivement CheckBox1 et CheckBox2
- Trois Frames nommées respectivement Frame1, Frame2 et Frame3
Ensuite, nous allons créer une collection pour persister les instances de chaque MouseCursorAdvanced.
' Collection pour persister les instances de chaque CursorAdvanced
Private cursorAdvancedCollection As Collection
Private Sub UserForm_Initialize()
' Instanciation de la collection
Set cursorAdvancedCollection = New Collection
' Affectation de nouveaux curseurs aux différents contrôles
Call AffectCursorOnMSFormsControl(Me.Label1, WINDOW_ICON_HAND)
Call AffectCursorOnMSFormsControl(Me.CheckBox1, WINDOW_ICON_HAND)
Call AffectCursorOnMSFormsControl(Me.CheckBox2, WINDOW_ICON_UPARROW)
Call AffectCursorOnMSFormsControl(Me.Frame1, WINDOW_ICON_IBEAM)
Call AffectCursorOnMSFormsControl(Me.Frame2, WINDOW_ICON_APPSTARTING)
Call AffectCursorOnMSFormsControl(Me.Frame3, WINDOW_ICON_NO)
End Sub
Private Sub AffectCursorOnMSFormsControl(control As MSForms.control, cursorType As CursorTypes)
Dim cursorAdvanced As MouseCursorAdvanced
Set cursorAdvanced = New MouseCursorAdvanced
Call cursorAdvanced.Initialize(control, cursorType)
' Ajout dans la collection
Call cursorAdvancedCollection.Add(cursorAdvanced)
End SubTests avec différents curseurs dans un USERFRAME DYNAMIQUE
Dans cette exemple, on a un UserForm qui créer dynamiquement ces contrôles à l'instanciation.
Pour chaque type de curseurs, stockés dans le tableau cursors, il est créer un label et une frame spécifique.
Puis on change son curseur via l'appel de la procédure
Call AffectCursor(cursorLabel, cursorInString)
Call AffectCursor(cursorFrame, cursorInString)Voila le code complet pour tester différents curseurs.
Option Explicit
Private cursorAdvancedCollection As Collection
Private Sub UserForm_Initialize()
Set cursorAdvancedCollection = New Collection
Dim cursors As Variant
cursors = Array( _
"WINDOW_ICON_ARROW", _
"WINDOW_ICON_IBEAM", _
"WINDOW_ICON_WAIT", _
"WINDOW_ICON_CROSS", _
"WINDOW_ICON_UPARROW", _
"WINDOW_ICON_SIZENWSE", _
"WINDOW_ICON_SIZENESW", _
"WINDOW_ICON_SIZEWE", _
"WINDOW_ICON_SIZENS", _
"WINDOW_ICON_SIZEALL", _
"WINDOW_ICON_NO", _
"WINDOW_ICON_HAND", _
"WINDOW_ICON_APPSTARTING", _
"CURSOR_TYPE_UNINITIALIZED" _
)
Call CreateControls(cursors)
End Sub
Private Sub CreateControls(itemList As Variant)
Dim i As Integer
Dim cursorLabel As MSForms.Label
Dim cursorFrame As MSForms.frame
Dim margin As Integer
margin = 10
Dim currentTop As Integer
currentTop = margin
Dim colors As Variant
colors = Array(RGB(20, 20, 0), RGB(20, 40, 0), RGB(20, 60, 0), RGB(20, 80, 0), RGB(20, 100, 0), RGB(20, 120, 0))
For i = LBound(itemList) To UBound(itemList)
Dim cursorInString As String
cursorInString = itemList(i)
Set cursorLabel = Me.Controls.Add("Forms.Label.1", "cursorLabel_" & cursorInString, True)
With cursorLabel
.Caption = cursorInString
.Left = margin
.Top = currentTop
.Width = 200
End With
Set cursorFrame = Me.Controls.Add("Forms.Frame.1", "cursorFrame_" & cursorInString, True)
With cursorFrame
.Width = 100
.Height = cursorLabel.Height
.Left = cursorLabel.Left + cursorLabel.Width + margin
.Top = cursorLabel.Top
.SpecialEffect = fmSpecialEffectFlat
.BackColor = colors(i Mod (UBound(colors) + 1))
End With
Call AffectCursor(cursorLabel, cursorInString)
Call AffectCursor(cursorFrame, cursorInString)
currentTop = cursorFrame.Top + cursorFrame.Height + margin
Next i
Me.Height = currentTop + 3 * margin
End Sub
Private Sub AffectCursor(control As MSForms.control, cursorInString As String)
Dim cursorAdvanced As MouseCursorAdvanced
Set cursorAdvanced = New MouseCursorAdvanced
Dim cursorType As CursorTypes
cursorType = cursorAdvanced.GetCursorType(cursorInString)
Call cursorAdvanced.Initialize(control, cursorType)
Call cursorAdvancedCollection.Add(cursorAdvanced)
End SubBonjour,
Beau développement mais un peu compliqué alors qu'il suffit d'intégrer dans le contrôle le fichier image qui servira de pointeur pour la souris.
Pour cela il faut d'abord récupérer les icônes nécessaires et les stockées.
- On en trouve facilement sur le Net,
- On peut également les créer avec un logiciel gratuit comme "Greenfish Icon Editor",
- Ou encore aller chercher les icônes stockées dans les Dll des programmes en utilisant un programme d'extraction comme "Extracteur d'icônes de Laurent Trohel".
Ensuite, dans les propriétés du contrôle : MousePointer choisir 99 (FmMousePointerCustom) et pour MouseIcon aller chercher le fichier icône.
L'image sera intégrée au formulaire (pas besoin de la livrer avec l'appli).
Exemple avec l'icône d'une main bleue.
Pour ce qui concerne l'image utilisée comme icône, il faut être attentif au "point chaud". Dans le fichier joint, la main est en bas, de façon à apparaître correctement sur le bouton (voir info dans le zip).
Cela dit, le programme proposé semble parfait (non testé) pour ceux qui ne veulent pas de prendre la tête avec la gestion des icônes (création / extraction / mise au point ...).
Eric
Hello Eric,
L'idée c'est d'avoir exactement le même look que les icones du système d'exploitation... mais tu as raison sa mise en œuvre est bien plus complexe que celle d'utiliser des icones personnalisés.
L'avantage d'utiliser l'API Windows ce que tu n'a pas de travail préparatoire pour récupère les fichiers icônes, et tu t'assures d'avoir une qualité identique à ceux du système d'exploitation. Je ne suis pas sur qu'on arrive au même rendu visuel et à la même qualité d'intégration avec des icones personnalisés (FmMousePointerCustom). Mais ce la reste une option efficace et facile à mettre en oeuvre
Cordialement.