Hook na Scrollu Myszy   strona główna:
A po co ten Excel ;-)
 
    To rozwiązanie nie jest moje, jedynie dostosowałem go do moich potrzeb, a może jeszcze komuś się przyda..  
 
Zadanie jest takie: w Arkuszy są osadzone: ListBox (ActiveX), ComboBox (ActiveX), ComboBox (Excel.DropDown). Chciałbym żeby  
                          scroll nad tymi kontrolkami nie przesuwał wierszy arkusza a wybierał kolejne pozycje z list tych kontrolek. Jednak  
                          jak kursor znajduje się gdzie indziej - scroll działa normalnie.  
 
Jedno słowo.. NIEWYKONALNE!! … Gdyby nie przykład Tajana zamieszczony na excelforum.pl który zmienia wartość komórki scrolem   scrool-myszy-procedura-zdarzeniowa
 excelforum.pl
myszy :-D   
    Tę procedurę dostosujemy do naszego zadania..  
 
Niekomentowalna częśc kodu to…  
 
 
Option Explicit  
 
Declare Sub CopyMemory _  
    Lib "kernel32" _  
    Alias "RtlMoveMemory" ( _  
        ByVal Destination As Long, _  
        ByVal Source As Long, _  
        ByVal Length As Long)  
 
Declare Function SetWindowsHookEx _  
    Lib "user32" _  
    Alias "SetWindowsHookExA" ( _  
        ByVal idHook As Long, _  
        ByVal lpfn As Long, _  
        ByVal hmod As Long, _  
        ByVal dwThreadId As Long) _  
    As Long  
 
Declare Function CallNextHookEx _  
    Lib "user32" ( _  
        ByVal hHook As Long, _  
        ByVal nCode As Long, _  
        ByVal wParam As Long, _  
        lParam As Any) _  
    As Long  
 
Declare Function UnhookWindowsHookEx _  
    Lib "user32" ( _  
        ByVal hHook As Long) _  
    As Long  
 
Declare Function GetActiveWindow _  
    Lib "user32" () As Long  
 
Declare Function FindWindow _  
    Lib "user32" _  
    Alias "FindWindowA" ( _  
        ByVal lpClassName As String, _  
        ByVal lpWindowName As String) _  
    As Long  
 
Declare Function GetCursorPos _  
    Lib "user32" ( _  
        lpPoint As POINTAPI) _  
    As Long  
 
Public Type POINTAPI  
    x As Long  
    y As Long  
End Type  
 
Type MSLLHOOKSTRUCT  
    pt As POINTAPI  
    mouseData As Long  
    flags As Long  
    time As Long  
    dwExtraInfo As Long  
End Type  
 
Const HC_ACTION = 0  
Const WH_MOUSE_LL = 14  
 
Const WM_MOUSEWHEEL = &H20A  
 
Dim hhkLowLevelMouse As Long  
Dim udtlParamStuct  As MSLLHOOKSTRUCT  
 
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT  
  CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)  
  GetHookStruct = udtlParamStuct  
End Function  
 
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long  
  On Error Resume Next  
  Dim bMouseProc As Boolean, bEnd As Boolean  
  If GetActiveWindow = FindWindow("XLMAIN", Application.Caption) Then  
      If (nCode = HC_ACTION) Then  
        
        Select Case wParam  
            Case WM_MOUSEWHEEL  
              
            Scroll lParam, bMouseProc, bEnd  
              
            LowLevelMouseProc = bMouseProc  
            If bEnd Then Exit Function  
              
        End Select  
 
      End If  
  End If  
 
  LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)  
End Function  
 
Sub Hook_Mouse()  
  hhkLowLevelMouse = SetWindowsHookEx _  
                     (WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)  
End Sub  
 
Sub UnHook_Mouse()  
  If hhkLowLevelMouse <> 0 Then UnhookWindowsHookEx hhkLowLevelMouse  
End Sub  
 
Sub Start()  
    Hook_Mouse  
End Sub  
 
Sub StopProc()  
    UnHook_Mouse  
End Sub  
 
Zmieniłem jedynie..  
 
        Select Case wParam  
            Case WM_MOUSEWHEEL  
              
            Scroll lParam, bMouseProc, bEnd  
              
            LowLevelMouseProc = bMouseProc  
            If bEnd Then Exit Function  
              
        End Select  
 
Może jedynie dwa słowa o WM_MOUSEWHEEL   WM_MOUSEWHEEL message
Nie jest to funkcja czy procedura a "wiadomość" wysyłana do aktywnego okna. Okazuje się że możemy przechwytywać te wiadomości  
i jeżeli wystąpią podpiąć do ich działania, albo zamiast niego, swoją własną procedurę. :-) Jest dużo innych wiadomości które można  
przechwycić i wykorzystać po swojemu. To jakby nowe zdarzenia którymi możemy się posługiwać.  
 
I procedura Scroll:  
 
Option Explicit  
 
Sub Scroll(HookStructLParam As Long, ByRef czyZdarzenieNastapilo As Boolean, ByRef bFlag As Boolean)  
 
    Dim objShp As Object  
    Dim point As POINTAPI: GetCursorPos point  
      
    On Error Resume Next  
    Set objShp = ActiveWindow.RangeFromPoint(x:=point.x, _  
                                             y:=point.y)  
    On Error GoTo 0  
    'MsgBox TypeName(objShp): Debug.Print TypeName(objShp)  
    Select Case TypeName(objShp)  
        Case "OLEObject"  
            If TypeName(objShp.Object) = "ListBox" Or _  
               TypeName(objShp.Object) = "ComboBox" Then  
                 
                With objShp.Parent.OLEObjects(objShp.Name).Object  
                    If GetHookStruct(HookStructLParam).mouseData > 0 Then  
                        If .ListIndex > -1 Then  
                            .ListIndex = .ListIndex - 1  
                        End If  
                    Else  
                        If .ListIndex < .ListCount - 1 Then  
                            .ListIndex = .ListIndex + 1  
                        End If  
                    End If  
                      
                    czyZdarzenieNastapilo = True: bFlag = True  
                End With  
            End If  
                      
        Case "DropDown"  
            With objShp  
                If GetHookStruct(HookStructLParam).mouseData > 0 Then  
                    If .ListIndex > -1 Then  
                        .ListIndex = .ListIndex - 1  
                    End If  
                Else  
                    If .ListIndex < .ListCount - 1 Then  
                        .ListIndex = .ListIndex + 1  
                    End If  
                End If  
                      
                czyZdarzenieNastapilo = True: bFlag = True  
            End With  
        Case "Range"  
            '...  
        Case "Nothing"  
            czyZdarzenieNastapilo = True: bFlag = True  
 
    End Select  
      
    Set objShp = Nothing  
End Sub  
 
Fragmentami..  
 
    Dim objShp As Object  
    Dim point As POINTAPI: GetCursorPos point  
      
    On Error Resume Next  
    Set objShp = ActiveWindow.RangeFromPoint(x:=point.x, _  
                                             y:=point.y)  
    On Error GoTo 0  
 
Kłopotem jest nasze założenie. Scroll działa inaczej jedynie jeżeli kursor znajduje się nad określoną kontrolką. Skąd jednak wiedzieć  
nad czym znajduje się kursor? No bo jedyne co wiemy to pozycja kursowa. Po to właśnie metoda RangeFromPoint  
Z pomocy VBA nt. tej metody:  
 
Window.RangeFromPoint Method  
Returns the Shape or Range object that is positioned at the specified pair of screen coordinates.  
If there isn’t a shape located at the specified coordinates, this method returns Nothing.  
 
A więc dzięki tej metodzie możemy rozróżniać obiekty nad którymi znajduje się kursor. Więc w zależności od TypeName tego obiektu  
różnie zareagujemy (to już w kodzie).  
 
Wyjaśnić należałoby jeszcze   
 
                czyZdarzenieNastapilo = True: bFlag = True  
 
Tu nadaję odpowiednią wartość zmiennym które trafią przez Referencję do funkcji LowLevelMouseProc. Określamy tu czy scroll ma    
zadziałać po wykonaniu się naszej procedury czy nie.   Przykład do pobrania:
  scrollhook.zip