[[20150109095044]]　『テキストボックスでマウスホイールを有効にしたい』（らくだ）　ページの最後に飛ぶ

『テキストボックスでマウスホイールを有効にしたい』（らくだ）

Excelのユーザーフォームにテキストボックスを配置して、multilineをtrueにし、Scrollbarをつけたのですが、マウスホイールでスクロールさせることができません。

どこでもホイールでできることはわかっているのですが、会社の規則で、新たにアプリケーションを入れたりすることができないので、コードで何とかするしかない状況です。

どのように書けばいいんでしょうか？
よろしくお願い申し上げます。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 なんか昔考えた気がするけど、コンボボックスだった。
[[20141022104627]]

 一応テストしたけど、コンボボックスをテキストボックスに読み替えればそこそこ動きました！
（稲葉） 2015/01/09(金) 10:14

 横から失礼します。

 以前ネットで見掛けたコードです。
 出典はどこだったか分かりません。
 申し訳ないですが、私自身良く理解して使っているわけではありませんので解説出来ません。

 ホイール上下でカーソルが上下移動、Ctrlキー押しながらホイール上下でカーソルが左右移動
 します。

 クラスモジュールを使用します。
 クラスモジュールを挿入し、オブジェクト名を「clsHookMessage」に変えておきます。

'クラスモジュール/オブジェクト名：clsHookMessage
'-------- クラスモジュール(clsHookMessage) --------

Public Enum hmMessageEnum

    WM_MOUSEWHEEL = &H20A
End Enum
Public Event Message( _
        ByRef hWnd As Long, ByRef uMsg As hmMessageEnum, _
        ByRef wParam As Long, ByRef lParam As Long, _
        ByRef lResult As Long, ByRef Cancel As Boolean)

Private Declare Function GetModuleHandle Lib "kernel32" _

        Alias "GetModuleHandleA" _
        (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" _
        (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetWindowLong Lib "user32" _
        Alias "GetWindowLongA" _
        (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
        Alias "SetWindowLongA" _
        (ByVal hWnd As Long, ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long
Const GWL_WNDPROC = -4
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VirtualAlloc Lib "kernel32" _
        (ByVal lpAddress As Long, ByVal dwSize As Long, _
        ByVal flAllocationType As Long, _
        ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" _
        (ByVal lpAddress As Long, ByVal dwSize As Long, _
        ByVal dwFreeType As Long) As Long
Const PAGE_EXECUTE_READWRITE = &H40
Const MEM_COMMIT = &H1000
Const MEM_RESERVE = &H2000
Const MEM_RELEASE = &H8000&
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function FlushInstructionCache Lib "kernel32" _
        (ByVal hProcess As Long, lpBaseAddress As Any, _
        ByVal dwSize As Long) As Long

Private m_hwnd As Long
Private m_pProc As Long

Private Sub Class_Terminate()

    EndHook
End Sub

' サブクラス化開始
Friend Sub StartHook(ByVal hWnd As Long, ByVal Msg As hmMessageEnum)

    Const cstrCode = _
            "08247C8100000000B990107400000000B950515800000000" & _
            "006AE1FF006AD48BB852CC8B00000000144A8D51104A8D51" & _
            "0C4A8D51084A8D5150088B51591C51FF74C985580010C2C6"
    Dim Code() As Long
    Dim lngCodeLen As Long
    Dim i As Long

    EndHook
    If hWnd = 0 Then
        Err.Clear
        Err.Raise 5
    End If

    ReDim Code(0 To (Len(cstrCode) - 1) \ 8)
    For i = 0 To UBound(Code)
        Code(i) = "&H" & Mid$(cstrCode, 1 + i * 8, 8)
    Next
    Code(1) = Msg
    Code(3) = GetWindowLong(hWnd, GWL_WNDPROC)
    Code(5) = GetProcAddress(GetModuleHandle("user32.dll"), _
                             "CallWindowProcA")
    Code(9) = ObjPtr(Me)

    lngCodeLen = (UBound(Code) + 1) * 4
    m_pProc = VirtualAlloc(0, lngCodeLen, MEM_RESERVE Or MEM_COMMIT, _
                           PAGE_EXECUTE_READWRITE)
    If m_pProc = 0 Then
        Err.Clear
        Err.Raise 7
    End If
    MoveMemory ByVal m_pProc, Code(0), lngCodeLen
    FlushInstructionCache GetCurrentProcess(), ByVal m_pProc, lngCodeLen
    SetWindowLong hWnd, GWL_WNDPROC, m_pProc
    m_hwnd = hWnd

End Sub

' サブクラス化終了
Friend Sub EndHook()

    Dim pOrgProc As Long
    If m_pProc = 0 Then Exit Sub
    MoveMemory pOrgProc, ByVal m_pProc + 12, 4
    SetWindowLong m_hwnd, GWL_WNDPROC, pOrgProc
    VirtualFree m_pProc, 0, MEM_RELEASE
    m_pProc = 0
End Sub

' 指定したメッセージの発生時に呼ばれるコールバック関数
Public Function WndProc(ByRef hWnd As Long, ByRef uMsg As Long, _

                        ByRef wParam As Long, ByRef lParam As Long, _
                        ByRef Cancel As Boolean) As Long

    Dim lngResult As Long
    RaiseEvent Message(hWnd, uMsg, wParam, lParam, lngResult, Cancel)
    WndProc = lngResult

End Function

'※ここから下はユーザーフォームに記述

'UserFormモジュール/テキストボックスを配置しておく
Private Declare Function WindowFromObject Lib "oleacc" _

        Alias "WindowFromAccessibleObject" _
        (ByVal pacc As Object, phwnd As Long) As Long

Private WithEvents m_Wheel As clsHookMessage
Private Declare Function PostMessage Lib "user32" _

        Alias "PostMessageA" _
        (ByVal hWnd As Long, ByVal Msg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long
Const WM_KEYDOWN = &H100
Const MK_CONTROL = &H8
Const MK_SHIFT = &H4

Private Sub m_Wheel_Message( _

    ByRef hWnd As Long, ByRef uMsg As hmMessageEnum, _
    ByRef wParam As Long, ByRef lParam As Long, _
    ByRef lResult As Long, ByRef Cancel As Boolean)
On Error GoTo Err_Handler
    Dim lngkey As Long

    If (wParam And &HFFFF&) And MK_CONTROL Then
        If wParam > 0 Then
            lngkey = vbKeyLeft
        Else
            lngkey = vbKeyRight
        End If
    Else
        If wParam > 0 Then
            lngkey = vbKeyUp
        Else
            lngkey = vbKeyDown
        End If
    End If
    PostMessage hWnd, WM_KEYDOWN, lngkey, 0

Err_Handler:
End Sub

Private Sub UserForm_Initialize()

    Dim hWnd As Long
    WindowFromObject Me, hWnd
    Set m_Wheel = New clsHookMessage
    m_Wheel.StartHook hWnd, hmMessageEnum.WM_MOUSEWHEEL

    TextBox1.ScrollBars = fmScrollBarsBoth
    TextBox1.MultiLine = True

End Sub

Private Sub UserForm_QueryClose( _
Cancel As Integer, CloseMode As Integer)

    Set m_Wheel = Nothing

End Sub
（カリーニン） 2015/01/09(金) 10:55

お世話になっております。

稲葉さんの方法でできました！
ありがとうごさいます。

カリーニンさんの方法ではうまく行かず、エラーにもならなくて、反応なしでした。

私の書き方のどこかに不備があると思うので、研究してみます。
ありがとうごさいました。
（らくだ） 2015/01/09(金) 13:43

コメント返信：

[ 一覧(最新更新順) ]

[[20150109095044]] 『テキストボックスでマウスホイールを有効にしたい』（らくだ） ページの最後に飛ぶ

[[20150109095044]]　『テキストボックスでマウスホイールを有効にしたい』（らくだ）　ページの最後に飛ぶ