Это добавляем в модуль. Обзовем его для удобства WheelScroll.bas
- Код: Выделить всё
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) 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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Const GWL_WNDPROC = (-4)
Public Const GWL_STYLE = (-16)
Public Const WM_MOUSEWHEEL = &H20A
Public Const WM_VSCROLL = &H115
Public Const SB_LINEDOWN = 1
Public Const SB_LINEUP = 0
Public Const SB_ENDSCROLL As Long = 8
Public Const WS_VSCROLL As Long = &H200000
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type POINTAPI
X As Long
Y As Long
End Type
Public hWndClient As Long
Dim PrevProc As Long
Public Sub HookForm(hwnd As Long)
PrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHookForm(hwnd As Long)
SetWindowLong hwnd, GWL_WNDPROC, PrevProc
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case WM_MOUSEWHEEL
ScrollMove (wParam)
End Select
WindowProc = CallWindowProc( _
PrevProc, hwnd, uMsg, wParam, lParam)
End Function
Public Function MouseOver(ObjectHwnd As Long) As Boolean
Dim ObjCoord As RECT
Dim CursCoord As POINTAPI
GetWindowRect ObjectHwnd, ObjCoord
GetCursorPos CursCoord
If (ObjCoord.Left < CursCoord.X) And (CursCoord.X < ObjCoord.Right) And (ObjCoord.Top < CursCoord.Y) And (CursCoord.Y < ObjCoord.Bottom) Then
MouseOver = True
Else
MouseOver = False
End If
End Function
Public Function CheckScroll(hwnd As Long) As Boolean
Dim Style As Long
Dim tmpStyle As Long
Style = GetWindowLong(hwnd, GWL_STYLE)
tmpStyle = Style
Style = Style Or WS_VSCROLL
If tmpStyle <> Style Then
CheckScroll = False
Else
CheckScroll = True
End If
End Function
Public Sub ScrollMove(wParam As Long)
If CheckScroll(hWndClient) And MouseOver(hWndClient) Then
If wParam < 0 Then
SendMessage hWndClient, WM_VSCROLL, SB_LINEDOWN, 0
Else
SendMessage hWndClient, WM_VSCROLL, SB_LINEUP, 0
End If
SendMessage hWndClient, WM_VSCROLL, SB_ENDSCROLL, 0
End If
End Sub
А это добавляем в родительскую MDI форму:
- Код: Выделить всё
Private Sub MDIForm_Load()
hWndClient = FindWindowEx(Me.hwnd, 0, "MDIClient", "")
HookForm Me.hwnd
End Sub
Private Sub MDIForm_Unload(Cancel As Integer)
UnHookForm Me.hwnd
End Sub
Все! Поддержка колесика у формы теперь есть.
P.S. Спасибо Odrick'у за то, что направил в нужное русло для написания этого кода.