Ипользование колесика для прокрутки содержимого MDI формы

Здесь можно найти готовые «кирпичики» — части кода, пригодные для построения более крупных проектов, а также решения различных типовых и не очень задач на VB.

Модератор: Brickgroup

Gigahard
Бывалый
Бывалый
 
Сообщения: 253
Зарегистрирован: 24.07.2002 (Ср) 11:15
Откуда: Russia

Ипользование колесика для прокрутки содержимого MDI формы

Сообщение Gigahard » 20.01.2006 (Пт) 16:59

К сожалению в VB6 отсутствует поддержка колесика мышки для прокручивания содержимого MDI формы. Эту проблему позволяет решить нижеприведенный код:
Это добавляем в модуль. Обзовем его для удобства 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'у за то, что направил в нужное русло для написания этого кода.
Старый глюк лучше новых двух!

Вернуться в Кирпичный завод

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 6

    TopList