Реализуйте колесо мыши в msforms.textbox - PullRequest
Новая
       18

Реализуйте колесо мыши в msforms.textbox

0 голосов
/ 01 декабря 2018

Я пытаюсь реализовать прокрутку колесика мыши в большом текстовом поле.Я нашел код Питера Торнтона, и он хорошо работает для фреймов и пользовательских форм (сейчас он используется только для первого), но не для текстового поля, потому что у текстовых полей нет свойства .ScrollTop.

КодЯ использую сейчас не на самом деле функция колеса прокрутки.Полный код приведен ниже, но соответствующая часть: 

If TypeName(mControl) = "TextBox" Then
    If reasonCustKeyPressed Then
        lngSelStart = .SelStart
        .CurLine = .CurLine
        lngOldLinePos = lngSelStart - .SelStart
        reasonCustKeyPressed = False
    End If
    If lParam.Hwnd > 0 Then
        .CurLine = Application.Max(0, .CurLine - cTBOX_SCROLLCHANGE)
    Else
        .CurLine = Application.Min(.LineCount - 1, .CurLine + cTBOX_SCROLLCHANGE)
    End If
    lngSelStart = .SelStart
    If .CurLine < .LineCount - 1 Then
        .CurLine = .CurLine + 1
        .SelStart = .SelStart - 1
    Else
        .SelStart = Len(.Text)
    End If
    lngNewLineLen = .SelStart - lngSelStart
    .SelStart = Application.Min(lngSelStart + lngOldLinePos, lngSelStart + lngNewLineLen)
End If

Кто-нибудь может дать какие-либо предложения о том, как я могу реализовать реальную функциональность колеса прокрутки?У меня есть идея найти:

  1. Была ли активна полоса прокрутки (контент не всегда достаточно длинный, чтобы его активировать - но не знаю как, Windows API?).
  2. Сохранение .SelStart во временной переменной
  3. Как-то найти верхнюю / нижнюю строку (я не могу найти какое-либо свойство текстового поля, подобного этому в документации)
  4. Увеличить нижнююлиния / уменьшить верхнюю строку (при необходимости), установив .CurLine
  5. Сброс .SelStart во временную переменную (или верхнюю / нижнюю строку, если строка, сохраненная во временной переменной, больше не видна).

Однако это не идеальный вариант, поскольку он не сохраняет предыдущую позицию курсора, если вы прокручиваете слишком далеко.Я мог бы обойти это, сохранив переменную .SelStart в состоянии модуля и вернувшись к нему в событии KeyDown.Однако есть некоторые действительно большие пробелы, и я не совсем понимаю, как их заполнить.Есть идеи (для того или иного, более элегантного решения)?Заранее спасибо.

Полный код: 

Option Explicit
 ' Based on code from Peter Thornton here:
 ' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
Private Type POINTAPI
    X                               As Long
    y                               As Long
End Type
Private Type MOUSEHOOKSTRUCT
    pt                              As POINTAPI
    Hwnd                            As Long
    wHitTestCode                    As Long
    dwExtraInfo                     As Long
End Type

Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal Hwnd As Long, _
ByVal nIndex As Long) As Long

Private 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

Private Declare Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long

Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long

Private Declare Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" ( _
ByVal Hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

Private Declare Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long

Private Declare Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long

Declare Function GetActiveWindow Lib "user32" () As Long

Private Const WH_MOUSE_LL           As Long = 14
Private Const WM_MOUSEWHEEL         As Long = &H20A
Private Const HC_ACTION             As Long = 0
Private Const GWL_HINSTANCE         As Long = (-6)

Private Const WM_KEYDOWN            As Long = &H100
Private Const WM_KEYUP              As Long = &H101
Private Const VK_UP                 As Long = &H26
Private Const VK_DOWN               As Long = &H28
Private Const WM_LBUTTONDOWN        As Long = &H201

Private Const cFRAME_SCROLLCHANGE   As Long = 20
Private Const cTBOX_SCROLLCHANGE    As Long = 1

Private mLngMouseHook               As Long
Private mControlHwnd                As Long
Private mbHook                      As Boolean
Private lngOldLinePos               As Long
Dim mControl                        As Object


Sub HookFormScroll(oControl As Object, strFormCapt As String)
    Dim lngAppInst                  As Long
    Dim hwndUnderCursor             As Long

    Set mControl = oControl
    hwndUnderCursor = FindWindow("ThunderDFrame", strFormCapt)
    Debug.Print "Form window: " & hwndUnderCursor
    If mControlHwnd <> hwndUnderCursor Then
        UnhookFormScroll
        Debug.Print "Unhook old proc"
        mControlHwnd = hwndUnderCursor
        lngAppInst = GetWindowLong(mControlHwnd, GWL_HINSTANCE)
        If Not mbHook Then
            mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf mouseProc, lngAppInst, 0)
            mbHook = mLngMouseHook <> 0
            If mbHook Then Debug.Print "Form hooked"
        End If
    End If
End Sub

Sub UnhookFormScroll()
    If mbHook Then
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mControlHwnd = 0
        mbHook = False
    End If
End Sub

Private Function mouseProc( _
    ByVal nCode As Long, ByVal wParam As Long, _
    ByRef lParam As MOUSEHOOKSTRUCT) As Long
    Dim lngSelStart As Long, lngNewLineLen As Long
    On Error GoTo errH 'Resume Next
    If (nCode = HC_ACTION) Then
        If GetActiveWindow = mControlHwnd Then

            If wParam = WM_MOUSEWHEEL Then
                mouseProc = True
                With mControl
                    If TypeName(mControl) = "Frame" Then
                        If lParam.Hwnd > 0 Then
                            .ScrollTop = Application.Max(0, .ScrollTop - cFRAME_SCROLLCHANGE)
                        Else
                            .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + cFRAME_SCROLLCHANGE)
                        End If
                    Else
                        If TypeName(mControl) = "TextBox" Then
                            If reasonCustKeyPressed Then
                                lngSelStart = .SelStart
                                .CurLine = .CurLine
                                lngOldLinePos = lngSelStart - .SelStart
                                reasonCustKeyPressed = False
                            End If
                            If lParam.Hwnd > 0 Then
                                .CurLine = Application.Max(0, .CurLine - cTBOX_SCROLLCHANGE)
                            Else
                                .CurLine = Application.Min(.LineCount - 1, .CurLine + cTBOX_SCROLLCHANGE)
                            End If
                            lngSelStart = .SelStart
                            If .CurLine < .LineCount - 1 Then
                                .CurLine = .CurLine + 1
                                .SelStart = .SelStart - 1
                            Else
                                .SelStart = Len(.Text)
                            End If
                            lngNewLineLen = .SelStart - lngSelStart
                            .SelStart = Application.Min(lngSelStart + lngOldLinePos, lngSelStart + lngNewLineLen)
                        End If
                    End If
                End With
                Exit Function
            End If
        End If

    End If
    mouseProc = CallNextHookEx( _
    mLngMouseHook, nCode, wParam, ByVal lParam)
    Exit Function
errH:
    UnhookFormScroll
End Function
...