Je cherche =E0 intercepter un =E9v=E9nement de roulette de=20
souris sur un UserForm.
J'ai trouv=E9 une solution dans diverses sources sur le net=20
(notamment une d=E9mo de TPourtier)
Dans l'exemple ci-dessous, j'ai un simple UserForm1=20
contenant une ScrollBar1. Pour la ScrollBar, j'ai mis Min=20
=E0 0, Max =E0 1000 et SmallChange =E0 50.
Cela fonctionne parfaitement, la scrollbar ob=E9it =E0 toute=20
action sur la roulette de la souris, SAUF si j'affiche le=20
UserForm1 en mode NON MODAL. (Excel XP 2002)
Dans ce cas, un clic sur la bordure du UserForm, et=20
notamment sur la croix rouge de fermeture entraine un=20
plantage complet d'excel, alors que je n'ai aucun=20
probl=E8me si l'Usf est modal.
Pour compliquer le tout, j'utilise en plus dans mon appli=20
la possibilit=E9 de minimiser le UserForm par des API=20
(fonctionnalit=E9 suppl=E9mentaire non int=E9gr=E9e dans le code=20
ci-dessous, mais je le signale juste au cas o=F9 cela=20
poserait des probl=E8mes pour une =E9ventuelle solution).
Si quelqu'un trouve une solution, je lui en serais tr=E8s=20
reconnaissant, d'autant plus que j'ai bien conscience de=20
la difficult=E9 de mon probl=E8me.
Merci d'avance.
Laurent.
Voici le code:
1- Dans un module:
Declare Function FindWindow Lib "user32"=20
Alias "FindWindowA" (ByVal lpClassName As String, ByVal=20
lpWindowName As String) As Long
Declare Function GetDC Lib "user32.dll" (ByVal hwnd As=20
Long) As Long
Private Declare Function CallWindowProc Lib "user32.dll"=20
Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal MSG As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll"=20
Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const MK_CONTROL =3D &H8
Public Const MK_LBUTTON =3D &H1
Public Const MK_RBUTTON =3D &H2
Public Const MK_MBUTTON =3D &H10
Public Const MK_SHIFT =3D &H4
Private Const GWL_WNDPROC =3D -4
Private Const WM_MOUSEWHEEL =3D &H20A
Private hControl As Long
Private lPrevWndProc As Long
'appel=E9e quand l'=E9v=E9nement mousewheel est d=E9clench=E9
Private Sub MouseWheel(ByVal fwKeys As Long, _
ByVal zDelta As Long, _
ByVal xPos As Long, _
ByVal yPos As Long)
Dim sens As Integer
If UserForm1.ActiveControl.Name <> "ScrollBar1" Then=20
Exit Sub
=20
If zDelta < 0 Then sens =3D 1 Else sens =3D -1
UserForm1.Controle_ActualiseWheel=20
UserForm1.ActiveControl, sens
End Sub
Private Function WindowProc(ByVal lWnd As Long, _
ByVal lMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim fwKeys As Long
Dim zDelta As Long, xPos As Long, yPos As Long
If lMsg =3D WM_MOUSEWHEEL Then
fwKeys =3D wParam And 65535
zDelta =3D wParam / 65536
xPos =3D lParam And 65535
yPos =3D lParam / 65536
MouseWheel fwKeys, zDelta, xPos, yPos
End If
WindowProc =3D CallWindowProc(lPrevWndProc, lWnd, lMsg,=20
_
wParam, lParam)
End Function
'*********************************************************
****
'Hook
'*********************************************************
****
Public Sub Hook(ByVal hControl_ As Long)
hControl =3D hControl_
lPrevWndProc =3D SetWindowLong(hControl, GWL_WNDPROC, _
AddressOf WindowProc)
End Sub
'*********************************************************
****
'UnHook
'*********************************************************
****
Public Sub UnHook()
Call SetWindowLong(hControl, GWL_WNDPROC, lPrevWndProc)
End Sub
Function DCFenetreForm(CaptionFenetre As String) As Long
Dim hwnd As Long
'renvoie le hdc d'un UserForm (mais pas d'un contr=F4le)
hwnd =3D FindWindow(vbNullString, Me.Caption)
'hwnd =3D FindWindow(vbNullString, CaptionFenetre)
DCFenetreForm =3D GetDC(hwnd)
End Function
Function hwndFenetreForm(CaptionFenetre As String) As Long
hwndFenetreForm =3D FindWindow(vbNullString,=20
CaptionFenetre)
End Function
Function HwndFenetreXL() As Long
HwndFenetreXL =3D FindWindow("XLMAIN",=20
Application.Caption)
End Function
2- dans le code du UserForm1:
Private Sub UserForm_Activate()
Dim hwnd As Long
hwnd =3D hwndFenetreForm(Me.Caption)
If hwnd <> 0 Then Hook hwnd
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer,=20
CloseMode As Integer)
UnHook
End Sub
Public Sub Controle_ActualiseWheel(Control As=20
MSForms.Control, ByVal sens As Integer)
If sens =3D -1 Then
If UserForm1.ScrollBar1 -=20
UserForm1.ScrollBar1.SmallChange >=20
UserForm1.ScrollBar1.Min Then
UserForm1.ScrollBar1 =3D UserForm1.ScrollBar1 -=20
UserForm1.ScrollBar1.SmallChange
Else
UserForm1.ScrollBar1 =3D=20
UserForm1.ScrollBar1.Min
End If
Else
If UserForm1.ScrollBar1 +=20
UserForm1.ScrollBar1.SmallChange <=20
UserForm1.ScrollBar1.Max Then
UserForm1.ScrollBar1 =3D UserForm1.ScrollBar1 +=20
UserForm1.ScrollBar1.SmallChange
Else
UserForm1.ScrollBar1 =3D=20
UserForm1.ScrollBar1.Max
End If
End If
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
LaurentTBT
Bonjour,
ALors, personne n'a d'idée?
J'ai trouvé un artifice, mais très lourd à mettre en place: J'affiche mon UserForm en mode non modal, et à l'aide d'autres APIs, trouvées notamment sur le site de Fred Sigonneau, je crois, je fais supprimer la bande de titre de ce UserForm:
Private Declare Function FindWindowA Lib "user32" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLongA Lib "user32" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" _ (ByVal hWnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long _ , lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Sub UserForm_MouseDown(ByVal Button As Integer _ , ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ReleaseCapture SendMessage FindWindowA(vbNullString, Me.Caption), &HA1, 2, 0& End Sub
Private Sub UserForm_Initialize() Dim hWnd As Long, Style As Long
hWnd = FindWindowA(vbNullString, Me.Caption) Style = GetWindowLongA(hWnd, -16) And Not &HC00000 SetWindowLongA hWnd, -16, Style DrawMenuBar hWnd End Sub
Voilà, je vous l'ai dit, c'est lourd, car ensuite, je dessine en haut de mon UserForm un label pour avoir une simili barre de titre, qu'il faut dimensionner à chaque fois que mon USF change de dimensions (ce qui arrive souvent dans mon appli!), et en plus, j'y ajoute 2 petits boutons pour pouvoir minimizer, et pour fermer le userform, pour reproduire presque à l'identique la barre de titre initiale.
Bref, j'espère toujours trouver une solution plus directe, sinon, il va falloir attendre que Microsoft intègre la gestion de la roulette de la souris, peut-être pour les prochaines versions???
Bonjour,
Je cherche à intercepter un événement de roulette de souris sur un UserForm.
J'ai trouvé une solution dans diverses sources sur le net (notamment une démo de TPourtier)
Dans l'exemple ci-dessous, j'ai un simple UserForm1 contenant une ScrollBar1. Pour la ScrollBar, j'ai mis Min à 0, Max à 1000 et SmallChange à 50.
Cela fonctionne parfaitement, la scrollbar obéit à toute action sur la roulette de la souris, SAUF si j'affiche le UserForm1 en mode NON MODAL. (Excel XP 2002) Dans ce cas, un clic sur la bordure du UserForm, et notamment sur la croix rouge de fermeture entraine un plantage complet d'excel, alors que je n'ai aucun problème si l'Usf est modal.
Pour compliquer le tout, j'utilise en plus dans mon appli la possibilité de minimiser le UserForm par des API (fonctionnalité supplémentaire non intégrée dans le code ci-dessous, mais je le signale juste au cas où cela poserait des problèmes pour une éventuelle solution).
Si quelqu'un trouve une solution, je lui en serais très reconnaissant, d'autant plus que j'ai bien conscience de la difficulté de mon problème.
Merci d'avance.
Laurent.
Voici le code: 1- Dans un module:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _ ByVal lpPrevWndFunc As Long, _ ByVal hwnd As Long, _ ByVal MSG As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long
Public Const MK_CONTROL = &H8 Public Const MK_LBUTTON = &H1 Public Const MK_RBUTTON = &H2 Public Const MK_MBUTTON = &H10 Public Const MK_SHIFT = &H4 Private Const GWL_WNDPROC = -4 Private Const WM_MOUSEWHEEL = &H20A
Private hControl As Long Private lPrevWndProc As Long
'appelée quand l'événement mousewheel est déclenché Private Sub MouseWheel(ByVal fwKeys As Long, _ ByVal zDelta As Long, _ ByVal xPos As Long, _ ByVal yPos As Long) Dim sens As Integer
If UserForm1.ActiveControl.Name <> "ScrollBar1" Then Exit Sub
If zDelta < 0 Then sens = 1 Else sens = -1 UserForm1.Controle_ActualiseWheel UserForm1.ActiveControl, sens End Sub
Private Function WindowProc(ByVal lWnd As Long, _ ByVal lMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long
Dim fwKeys As Long Dim zDelta As Long, xPos As Long, yPos As Long
If lMsg = WM_MOUSEWHEEL Then fwKeys = wParam And 65535 zDelta = wParam / 65536 xPos = lParam And 65535 yPos = lParam / 65536 MouseWheel fwKeys, zDelta, xPos, yPos End If WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, _ wParam, lParam) End Function
'********************************************************* **** 'Hook '********************************************************* **** Public Sub Hook(ByVal hControl_ As Long) hControl = hControl_ lPrevWndProc = SetWindowLong(hControl, GWL_WNDPROC, _ AddressOf WindowProc) End Sub
'********************************************************* **** 'UnHook '********************************************************* **** Public Sub UnHook() Call SetWindowLong(hControl, GWL_WNDPROC, lPrevWndProc) End Sub
Function DCFenetreForm(CaptionFenetre As String) As Long Dim hwnd As Long 'renvoie le hdc d'un UserForm (mais pas d'un contrôle) hwnd = FindWindow(vbNullString, Me.Caption) 'hwnd = FindWindow(vbNullString, CaptionFenetre) DCFenetreForm = GetDC(hwnd) End Function
Function hwndFenetreForm(CaptionFenetre As String) As Long hwndFenetreForm = FindWindow(vbNullString, CaptionFenetre) End Function
Function HwndFenetreXL() As Long HwndFenetreXL = FindWindow("XLMAIN", Application.Caption) End Function
2- dans le code du UserForm1:
Private Sub UserForm_Activate() Dim hwnd As Long hwnd = hwndFenetreForm(Me.Caption) If hwnd <> 0 Then Hook hwnd End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) UnHook End Sub
Public Sub Controle_ActualiseWheel(Control As MSForms.Control, ByVal sens As Integer) If sens = -1 Then If UserForm1.ScrollBar1 - UserForm1.ScrollBar1.SmallChange > UserForm1.ScrollBar1.Min Then UserForm1.ScrollBar1 = UserForm1.ScrollBar1 - UserForm1.ScrollBar1.SmallChange Else UserForm1.ScrollBar1 = UserForm1.ScrollBar1.Min End If Else If UserForm1.ScrollBar1 + UserForm1.ScrollBar1.SmallChange < UserForm1.ScrollBar1.Max Then UserForm1.ScrollBar1 = UserForm1.ScrollBar1 + UserForm1.ScrollBar1.SmallChange Else UserForm1.ScrollBar1 = UserForm1.ScrollBar1.Max End If End If
End Sub
Bonjour,
ALors, personne n'a d'idée?
J'ai trouvé un artifice, mais très lourd à mettre en place:
J'affiche mon UserForm en mode non modal, et à l'aide d'autres APIs, trouvées notamment sur le site de Fred Sigonneau, je crois, je fais supprimer la bande de titre de ce UserForm:
Private Declare Function FindWindowA Lib "user32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLongA Lib "user32" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" _
(ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long _
, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Sub UserForm_MouseDown(ByVal Button As Integer _
, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ReleaseCapture
SendMessage FindWindowA(vbNullString, Me.Caption), &HA1, 2, 0&
End Sub
Private Sub UserForm_Initialize()
Dim hWnd As Long, Style As Long
hWnd = FindWindowA(vbNullString, Me.Caption)
Style = GetWindowLongA(hWnd, -16) And Not &HC00000
SetWindowLongA hWnd, -16, Style
DrawMenuBar hWnd
End Sub
Voilà, je vous l'ai dit, c'est lourd, car ensuite, je dessine en haut de mon UserForm un label pour avoir une simili barre de titre, qu'il faut dimensionner à chaque fois que mon USF change de dimensions (ce qui arrive souvent dans mon appli!), et en plus, j'y ajoute 2 petits boutons pour pouvoir minimizer, et pour fermer le userform, pour reproduire presque à l'identique la barre de titre initiale.
Bref, j'espère toujours trouver une solution plus directe, sinon, il va falloir attendre que Microsoft intègre la gestion de la roulette de la souris, peut-être pour les prochaines versions???
Bonjour,
Je cherche à intercepter un événement de roulette de
souris sur un UserForm.
J'ai trouvé une solution dans diverses sources sur le net
(notamment une démo de TPourtier)
Dans l'exemple ci-dessous, j'ai un simple UserForm1
contenant une ScrollBar1. Pour la ScrollBar, j'ai mis Min
à 0, Max à 1000 et SmallChange à 50.
Cela fonctionne parfaitement, la scrollbar obéit à toute
action sur la roulette de la souris, SAUF si j'affiche le
UserForm1 en mode NON MODAL. (Excel XP 2002)
Dans ce cas, un clic sur la bordure du UserForm, et
notamment sur la croix rouge de fermeture entraine un
plantage complet d'excel, alors que je n'ai aucun
problème si l'Usf est modal.
Pour compliquer le tout, j'utilise en plus dans mon appli
la possibilité de minimiser le UserForm par des API
(fonctionnalité supplémentaire non intégrée dans le code
ci-dessous, mais je le signale juste au cas où cela
poserait des problèmes pour une éventuelle solution).
Si quelqu'un trouve une solution, je lui en serais très
reconnaissant, d'autant plus que j'ai bien conscience de
la difficulté de mon problème.
Merci d'avance.
Laurent.
Voici le code:
1- Dans un module:
Declare Function FindWindow Lib "user32"
Alias "FindWindowA" (ByVal lpClassName As String, ByVal
lpWindowName As String) As Long
Declare Function GetDC Lib "user32.dll" (ByVal hwnd As
Long) As Long
Private Declare Function CallWindowProc Lib "user32.dll"
Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal MSG As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll"
Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const MK_CONTROL = &H8
Public Const MK_LBUTTON = &H1
Public Const MK_RBUTTON = &H2
Public Const MK_MBUTTON = &H10
Public Const MK_SHIFT = &H4
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private hControl As Long
Private lPrevWndProc As Long
'appelée quand l'événement mousewheel est déclenché
Private Sub MouseWheel(ByVal fwKeys As Long, _
ByVal zDelta As Long, _
ByVal xPos As Long, _
ByVal yPos As Long)
Dim sens As Integer
If UserForm1.ActiveControl.Name <> "ScrollBar1" Then
Exit Sub
If zDelta < 0 Then sens = 1 Else sens = -1
UserForm1.Controle_ActualiseWheel
UserForm1.ActiveControl, sens
End Sub
Private Function WindowProc(ByVal lWnd As Long, _
ByVal lMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim fwKeys As Long
Dim zDelta As Long, xPos As Long, yPos As Long
If lMsg = WM_MOUSEWHEEL Then
fwKeys = wParam And 65535
zDelta = wParam / 65536
xPos = lParam And 65535
yPos = lParam / 65536
MouseWheel fwKeys, zDelta, xPos, yPos
End If
WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg,
_
wParam, lParam)
End Function
'*********************************************************
****
'Hook
'*********************************************************
****
Public Sub Hook(ByVal hControl_ As Long)
hControl = hControl_
lPrevWndProc = SetWindowLong(hControl, GWL_WNDPROC, _
AddressOf WindowProc)
End Sub
'*********************************************************
****
'UnHook
'*********************************************************
****
Public Sub UnHook()
Call SetWindowLong(hControl, GWL_WNDPROC, lPrevWndProc)
End Sub
Function DCFenetreForm(CaptionFenetre As String) As Long
Dim hwnd As Long
'renvoie le hdc d'un UserForm (mais pas d'un contrôle)
hwnd = FindWindow(vbNullString, Me.Caption)
'hwnd = FindWindow(vbNullString, CaptionFenetre)
DCFenetreForm = GetDC(hwnd)
End Function
Function hwndFenetreForm(CaptionFenetre As String) As Long
hwndFenetreForm = FindWindow(vbNullString,
CaptionFenetre)
End Function
Function HwndFenetreXL() As Long
HwndFenetreXL = FindWindow("XLMAIN",
Application.Caption)
End Function
2- dans le code du UserForm1:
Private Sub UserForm_Activate()
Dim hwnd As Long
hwnd = hwndFenetreForm(Me.Caption)
If hwnd <> 0 Then Hook hwnd
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer,
CloseMode As Integer)
UnHook
End Sub
Public Sub Controle_ActualiseWheel(Control As
MSForms.Control, ByVal sens As Integer)
If sens = -1 Then
If UserForm1.ScrollBar1 -
UserForm1.ScrollBar1.SmallChange >
UserForm1.ScrollBar1.Min Then
UserForm1.ScrollBar1 = UserForm1.ScrollBar1 -
UserForm1.ScrollBar1.SmallChange
Else
UserForm1.ScrollBar1 =
UserForm1.ScrollBar1.Min
End If
Else
If UserForm1.ScrollBar1 +
UserForm1.ScrollBar1.SmallChange <
UserForm1.ScrollBar1.Max Then
UserForm1.ScrollBar1 = UserForm1.ScrollBar1 +
UserForm1.ScrollBar1.SmallChange
Else
UserForm1.ScrollBar1 =
UserForm1.ScrollBar1.Max
End If
End If
J'ai trouvé un artifice, mais très lourd à mettre en place: J'affiche mon UserForm en mode non modal, et à l'aide d'autres APIs, trouvées notamment sur le site de Fred Sigonneau, je crois, je fais supprimer la bande de titre de ce UserForm:
Private Declare Function FindWindowA Lib "user32" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLongA Lib "user32" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" _ (ByVal hWnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long _ , lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Sub UserForm_MouseDown(ByVal Button As Integer _ , ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ReleaseCapture SendMessage FindWindowA(vbNullString, Me.Caption), &HA1, 2, 0& End Sub
Private Sub UserForm_Initialize() Dim hWnd As Long, Style As Long
hWnd = FindWindowA(vbNullString, Me.Caption) Style = GetWindowLongA(hWnd, -16) And Not &HC00000 SetWindowLongA hWnd, -16, Style DrawMenuBar hWnd End Sub
Voilà, je vous l'ai dit, c'est lourd, car ensuite, je dessine en haut de mon UserForm un label pour avoir une simili barre de titre, qu'il faut dimensionner à chaque fois que mon USF change de dimensions (ce qui arrive souvent dans mon appli!), et en plus, j'y ajoute 2 petits boutons pour pouvoir minimizer, et pour fermer le userform, pour reproduire presque à l'identique la barre de titre initiale.
Bref, j'espère toujours trouver une solution plus directe, sinon, il va falloir attendre que Microsoft intègre la gestion de la roulette de la souris, peut-être pour les prochaines versions???
Bonjour,
Je cherche à intercepter un événement de roulette de souris sur un UserForm.
J'ai trouvé une solution dans diverses sources sur le net (notamment une démo de TPourtier)
Dans l'exemple ci-dessous, j'ai un simple UserForm1 contenant une ScrollBar1. Pour la ScrollBar, j'ai mis Min à 0, Max à 1000 et SmallChange à 50.
Cela fonctionne parfaitement, la scrollbar obéit à toute action sur la roulette de la souris, SAUF si j'affiche le UserForm1 en mode NON MODAL. (Excel XP 2002) Dans ce cas, un clic sur la bordure du UserForm, et notamment sur la croix rouge de fermeture entraine un plantage complet d'excel, alors que je n'ai aucun problème si l'Usf est modal.
Pour compliquer le tout, j'utilise en plus dans mon appli la possibilité de minimiser le UserForm par des API (fonctionnalité supplémentaire non intégrée dans le code ci-dessous, mais je le signale juste au cas où cela poserait des problèmes pour une éventuelle solution).
Si quelqu'un trouve une solution, je lui en serais très reconnaissant, d'autant plus que j'ai bien conscience de la difficulté de mon problème.
Merci d'avance.
Laurent.
Voici le code: 1- Dans un module:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _ ByVal lpPrevWndFunc As Long, _ ByVal hwnd As Long, _ ByVal MSG As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long
Public Const MK_CONTROL = &H8 Public Const MK_LBUTTON = &H1 Public Const MK_RBUTTON = &H2 Public Const MK_MBUTTON = &H10 Public Const MK_SHIFT = &H4 Private Const GWL_WNDPROC = -4 Private Const WM_MOUSEWHEEL = &H20A
Private hControl As Long Private lPrevWndProc As Long
'appelée quand l'événement mousewheel est déclenché Private Sub MouseWheel(ByVal fwKeys As Long, _ ByVal zDelta As Long, _ ByVal xPos As Long, _ ByVal yPos As Long) Dim sens As Integer
If UserForm1.ActiveControl.Name <> "ScrollBar1" Then Exit Sub
If zDelta < 0 Then sens = 1 Else sens = -1 UserForm1.Controle_ActualiseWheel UserForm1.ActiveControl, sens End Sub
Private Function WindowProc(ByVal lWnd As Long, _ ByVal lMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long
Dim fwKeys As Long Dim zDelta As Long, xPos As Long, yPos As Long
If lMsg = WM_MOUSEWHEEL Then fwKeys = wParam And 65535 zDelta = wParam / 65536 xPos = lParam And 65535 yPos = lParam / 65536 MouseWheel fwKeys, zDelta, xPos, yPos End If WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, _ wParam, lParam) End Function
'********************************************************* **** 'Hook '********************************************************* **** Public Sub Hook(ByVal hControl_ As Long) hControl = hControl_ lPrevWndProc = SetWindowLong(hControl, GWL_WNDPROC, _ AddressOf WindowProc) End Sub
'********************************************************* **** 'UnHook '********************************************************* **** Public Sub UnHook() Call SetWindowLong(hControl, GWL_WNDPROC, lPrevWndProc) End Sub
Function DCFenetreForm(CaptionFenetre As String) As Long Dim hwnd As Long 'renvoie le hdc d'un UserForm (mais pas d'un contrôle) hwnd = FindWindow(vbNullString, Me.Caption) 'hwnd = FindWindow(vbNullString, CaptionFenetre) DCFenetreForm = GetDC(hwnd) End Function
Function hwndFenetreForm(CaptionFenetre As String) As Long hwndFenetreForm = FindWindow(vbNullString, CaptionFenetre) End Function
Function HwndFenetreXL() As Long HwndFenetreXL = FindWindow("XLMAIN", Application.Caption) End Function
2- dans le code du UserForm1:
Private Sub UserForm_Activate() Dim hwnd As Long hwnd = hwndFenetreForm(Me.Caption) If hwnd <> 0 Then Hook hwnd End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) UnHook End Sub
Public Sub Controle_ActualiseWheel(Control As MSForms.Control, ByVal sens As Integer) If sens = -1 Then If UserForm1.ScrollBar1 - UserForm1.ScrollBar1.SmallChange > UserForm1.ScrollBar1.Min Then UserForm1.ScrollBar1 = UserForm1.ScrollBar1 - UserForm1.ScrollBar1.SmallChange Else UserForm1.ScrollBar1 = UserForm1.ScrollBar1.Min End If Else If UserForm1.ScrollBar1 + UserForm1.ScrollBar1.SmallChange < UserForm1.ScrollBar1.Max Then UserForm1.ScrollBar1 = UserForm1.ScrollBar1 + UserForm1.ScrollBar1.SmallChange Else UserForm1.ScrollBar1 = UserForm1.ScrollBar1.Max End If End If
End Sub
h2fooko
Malheureusement ce bug persiste avec MS Office 2003. Notamment avec Word 2003 (11.8215.8202) SP3. En ce qui me concerne cela m'a débloqué, puisque un UserForm Modal ne me dérange pas.
Peut être peut-on basculer en 'modal' - "non modal" en fonction de la position de la souris (X, Y) en utilisant:
Private Sub UserForm_MouseMove(ByVal Button As Integer, _ ByVal Shift As Integer, _ ByVal X As Single, _ ByVal Y As Single)
Me.Caption = StrTemp & " X = " & CStr(X) & " Y = " & CStr(Y) bMouseInStyleMap = X > 0 And X < WMax _ And Y > StyleMap.ScrollTop _ And Y < StyleMap.ScrollTop + HWinMax - 30 If bMouseInStyleMap Then mode modal Else mode non modal End If End Sub
Bon courage
Malheureusement ce bug persiste avec MS Office 2003.
Notamment avec Word 2003 (11.8215.8202) SP3.
En ce qui me concerne cela m'a débloqué, puisque un UserForm Modal ne me dérange pas.
Peut être peut-on basculer en 'modal' - "non modal" en fonction de la position de la souris (X, Y) en utilisant:
Private Sub UserForm_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
Me.Caption = StrTemp & " X = " & CStr(X) & " Y = " & CStr(Y)
bMouseInStyleMap = X > 0 And X < WMax _
And Y > StyleMap.ScrollTop _
And Y < StyleMap.ScrollTop + HWinMax - 30
If bMouseInStyleMap Then
mode modal
Else
mode non modal
End If
End Sub
Malheureusement ce bug persiste avec MS Office 2003. Notamment avec Word 2003 (11.8215.8202) SP3. En ce qui me concerne cela m'a débloqué, puisque un UserForm Modal ne me dérange pas.
Peut être peut-on basculer en 'modal' - "non modal" en fonction de la position de la souris (X, Y) en utilisant:
Private Sub UserForm_MouseMove(ByVal Button As Integer, _ ByVal Shift As Integer, _ ByVal X As Single, _ ByVal Y As Single)
Me.Caption = StrTemp & " X = " & CStr(X) & " Y = " & CStr(Y) bMouseInStyleMap = X > 0 And X < WMax _ And Y > StyleMap.ScrollTop _ And Y < StyleMap.ScrollTop + HWinMax - 30 If bMouseInStyleMap Then mode modal Else mode non modal End If End Sub
