TopPicLogo TopPicText

Текстовое Поле (MultiLine TextBox) - Вертикальная прокрутка колесом мышки (API)

В форме на событие Form_MouseWheel ("Колесико Мышки") - пишем:

Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)
    ScrollControlVertically Me!Название_Многострочного_Текстового_Поля , Count
End Sub


Модуль:

Option Compare Database
Option Explicit
'--------------------------------------------------------------------
' Module    : modScrollControlVertically_API
' Autor     : es
' Date      : 27.07.2016
' Purpose   : Вертикальная прокрутка контрола (MultiLine TextBox) колесом мышки (API)
'--------------------------------------------------------------------
'Эксплуотация
'В форме на событие Form_MouseWheel ("Колесико Мышки") - пишем:
'Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)
'    ScrollControlVertically Me!txtTextField, Count
'End Sub
'--------------------------------------------------------------------
'Scrolling Constants для SendMessage
Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
Private Const SB_LINEUP = 0
Private Const SB_LINEDOWN = 1
Private Const SB_PAGEUP = 2
Private Const SB_PAGEDOWN = 3
'--------------------------------------------------------------------
'GetScrollPos - Возвращает тек. позицию полосы прокрутки
Private Declare Function GetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long) As Long
'--------------------------------------------------------------------
'SendMessage - Тут для прокрутки MSG: SB_LINEUP | SB_LINEDOWN
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
'--------------------------------------------------------------------------
'GetFocusAPI - Возвращает дескриптор окна активного элемента управления (hWnd)
Private Declare Function GetFocusAPI Lib "user32" Alias "GetFocus" () As Long

Public Sub ScrollControlVertically(ctrl As Control, Count As Long)
'--------------------------------------------------------------------
' Вертикальная прокрутка колесом мышки
'--------------------------------------------------------------------
Dim hWndCtrl As Long       'Дескриптор контрола
Dim l As Long              'Сколько прокручиваем ...
Dim pos As Long            'Текущая позиция SCROLLBAR-a
Dim param%                 'Направление прокрутки
'--------------------------------------------------------------------
On Error GoTo ScrollControlVertically_Err
    ' Если полосы прокрутки у контрола нет - то делать тут нечего!
    If ctrl.ScrollBars <> 2 Then GoTo ScrollControlVertically_Bye
    
    hWndCtrl = GetControlWnd(ctrl) 'Получили дескриптор окна контрола
        
    'Собственно скроллинг:
    For l = 1 To Abs(Count)
        'Заглушка --------------------------------------------------------
        'что бы не возникало ошибок перемещения и было всё было тихо
        pos = GetScrollPos(hWndCtrl, 1) 'получаем позицию вертикального скролбара (0-100)
        'Дальше границ 0-100 преремещать нельзя!
        If pos = 0 And Count < 0 Or pos = 100 And Count > 0 Then Exit For
        'End of Заглушка -------------------------------------------------
        
        'Продолжаем
        If Count < 0 Then param = SB_LINEUP Else param = SB_LINEDOWN
        SendMessage hWndCtrl, WM_VSCROLL, param, 0&
    Next
    
    'DoEvents 'Обязательно!

ScrollControlVertically_Bye:
    Exit Sub

ScrollControlVertically_Err:
    'Debug.Print "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure ScrollControlVertically", vbCritical, "Error in module modGetControlWnd_API"
    Resume ScrollControlVertically_Bye
End Sub

Private Function GetControlWnd(ctrl As Control) As Long
'Возвращает дескриптор контрола (HWND) - Window Hundle
'--------------------------------------------------------------------------
On Error GoTo GetControlWnd_Err
    
    ctrl.SetFocus
    GetControlWnd = GetFocusAPI

GetControlWnd_Bye:
    Exit Function

GetControlWnd_Err:
    GetControlWnd = 0
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & "в процедуре: GetControlWnd", vbCritical, "Error in module modGetControlWnd_API"
    Resume GetControlWnd_Bye
End Function
Назад ToTop
L.E. 31.07.2016
Рейтинг@Mail.ru