VB и Excel

Option Explicit

'================================

Private Declare Function apiGetFocus Lib "user32" Alias "GetFocus" () As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const GWL_WNDPROC = (-4)
Private Const WM_MouseWheel As Long = &H20A
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KILLFOCUS As Long = &H8

Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_LBUTTONDBLCLK As Long = &H203
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_RBUTTONUP As Long = &H205
Private Const WM_RBUTTONDBLCLK As Long = &H206
Private Const WM_MBUTTONDOWN As Long = &H207
Private Const WM_MBUTTONUP As Long = &H208
Private Const WM_MBUTTONDBLCLK As Long = &H209



Private Const VK_DOWN As Long = &H28
Private Const VK_UP As Long = &H26

Public lpPrevWndProc As Long ' hWnd станд. функции обработчика окна
Public hndForm As Long       ' hWnd нашей формы

Public Sub HookForm(frm As Object)
   ' Устанавливает наш обработчик событий для формы
   '[frm] - ссылка на нашу форму. Передавайте так: Me
   
   On Error GoTo Err_
   If Len(frm.Caption) > 0 Then
     hndForm = FindWindow("ThunderDFrame", frm.Caption)
     If hndForm > 0 Then
       lpPrevWndProc = SetWindowLong(hndForm, GWL_WNDPROC, AddressOf WindowProc)
     Else
       Err.Raise vbObjectError + 1002
     End If
   Else
     Err.Raise vbObjectError + 1001
   End If
   
Ex_:
    Exit Sub

Err_:
  If Err.Number = 1001 Then
    MsgBox "Переданная форма имеет пустой заголовок(Caption)"
  Else
    MsgBox "Не получилось зарег. свой обработчик событий для формы."
  End If
  Resume Ex_
End Sub

Public Sub UnHookForm()
  ' Возвращает обратно станд. обработчик
  On Error GoTo Err_
 
  If hndForm > 0 Then _
    SetWindowLong hndForm, GWL_WNDPROC, lpPrevWndProc
Ex_:
    Exit Sub

Err_:
  MsgBox "Возникла ошибка при возвращении обратно станд. обработчика."
  Resume Ex_
End Sub


Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   ' Наш обработчик событий
   Dim hWndFocus As Long
   Dim hWndParent As Long
   Dim lpClassName As String
   Dim WHEEL_DELTA As Long
   Dim i As Integer
       
   ' обрабатываем событие - поворот колесика
   If uMsg = WM_MouseWheel Then
     ' проверям стоит ли фокус на каком-нибудь ListBox
     '------------------------------------------------
     hWndFocus = apiGetFocus
     ' буфер для имени класса окна
     lpClassName = Space(256)
     ' получаем имя класса активного элемента
     i = GetClassName(hWndFocus, lpClassName, 256)
     ' от пробелов освобождаемся
     lpClassName = Left(lpClassName, i)
     If lpClassName = "F3 Server 60000000" Then
       ' у родителя ListBox'a должен быть такой же класс,
       ' а если родителя нет, то это не ListBox, а клиент. часть формы
       '----------------------------------------------
       hWndParent = GetParent(hWndFocus)
       If hWndParent > 0 Then
         lpClassName = Space(256)
         i = GetClassName(hWndFocus, lpClassName, 256)
         lpClassName = Left(lpClassName, i)
         If lpClassName = "F3 Server 60000000" Then
           ' все OK, это ListBox работаем с ним дальше
           '------------------------------------------
           ' параметр WHEEL_DELTA хранится в High-word wParam
           WHEEL_DELTA = wParam / (2 ^ 8)
           If WHEEL_DELTA > 0 Then
             i = PostMessage(hWndFocus, WM_KEYDOWN, VK_UP, vbNull)
           Else
             i = PostMessage(hWndFocus, WM_KEYDOWN, VK_DOWN, vbNull)
           End If
         End If
       End If
     End If
   End If
   
   ' при потери фокуса возращаем старый обработчик
   ' чтобы тормозов было поменьше
'   If uMsg = WM_KILLFOCUS Then
'     UnHookForm
'   End If

   ' вызываем станд. функцию (которая была раньше)
   WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam)
End Function

Private Sub ListBox1_Enter()
  Call HookForm(Me)
End Sub

Private Sub ListBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call UnHookForm
End Sub