Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10 Pro : Excel 2013)
ユーザーフォーム上の複数のコンボボックスでマウスホイールスクロール
投稿日時: 17/09/30 22:28:41
投稿者: TiTi

コンボボックスのスクロールをマウスのホイールでやりたい(リオリオさんの質問)
http://www.moug.net/faq/viewtopic.php?t=75748 を見かけたので、
Abyss2さんのコードを実行してみました。
見事に、ユーザーフォーム上のコンボボックスでマウスホイールスクロールができました。
次に、2ケのコンボボックスで同様のことができるのかやってみました。
ユーザーフォーム上にComboBox1、ComboBox2を配置しました。
コードの変更箇所は、
 
Set cCombo = New clsWheel
    cCombo.Attach ComboBox1
の下に
Set cCombo2 = New clsWheel
    cCombo2.Attach ComboBox2
を追加し、
 
Private Sub cCombo_MouseWheel(ByVal acc As IAccessible, _
                          ByVal Delta As Integer, _
                          ByVal KeyState As Integer)
 
Dim idx As Long, cmb As ComboBox, isCloseUp As Boolean
    Delta = (Delta \ 120) * 2
 
    'Ctrlキー押下時はDelta値アップ
    If KeyState And MK_CONTROL Then Delta = Delta * 3
    'DropDownが表示されているかチェック
    isCloseUp = acc.accState(3&) And STATE_SYSTEM_INVISIBLE
    Set cmb = acc
 
    With cmb
        If isCloseUp Then
            idx = .ListIndex - Delta
            If idx < -1 Then idx = -1
            If idx > .ListCount - 1 Then idx = .ListCount - 1
            .ListIndex = idx
        Else
            idx = .TopIndex - Delta
            If idx < -1 Then idx = -1
            .TopIndex = idx
        End If
    End With
 
End Sub
 
のコードを複製して、
Private Sub cCombo2_MouseWheel(ByVal acc As IAccessible, _
                          ByVal Delta As Integer, _
                          ByVal KeyState As Integer)
Dim idx As Long, cmb As ComboBox, isCloseUp As Boolean
    Delta = (Delta \ 120) * 2
 
    'Ctrlキー押下時はDelta値アップ
    If KeyState And MK_CONTROL Then Delta = Delta * 3
    'DropDownが表示されているかチェック
    isCloseUp = acc.accState(3&) And STATE_SYSTEM_INVISIBLE
    Set cmb = acc
 
    With cmb
        If isCloseUp Then
            idx = .ListIndex - Delta
            If idx < -1 Then idx = -1
            If idx > .ListCount - 1 Then idx = .ListCount - 1
            .ListIndex = idx
        Else
            idx = .TopIndex - Delta
            If idx < -1 Then idx = -1
            .TopIndex = idx
        End If
    End With
 
End Sub
としました。
 
変数cCombo2は、変数cComboと同じく、
Private WithEvents cCombo2 As clsWheel
と宣言しました。
 
ComboBox2へのリストのセットは、ComboBox1と同じにしました。
 
以上のようにすると、ComboBox2でのみマウスホイールスクロールが可能となりました。
なぜ、ComboBox1でマウスホイールスクロールができないのでしょうか?
 
Win 10 ProとWin 8.1で、エクセルはどちらもExcel 2013です。
 
以上、どなたかご教示ください。
 
以下念の為、元のコードを掲載します。

引用:
【Classモジュール】clsWheel
Option Explicit
 
Private Declare Function WindowFromAccessibleObject& Lib "Oleacc" _
    (ByVal pacc As IAccessible, _
     ByRef phwnd&)
Private Declare Function GetClassNameW& Lib "User32" _
    (ByVal hWnd&, _
     ByVal lpClassName&, _
     ByVal nMaxCoun&)
Private Declare Function FindWindowExW& Lib "User32" _
    (Optional ByVal hwndParen&, _
     Optional ByVal hwndChildAfter&, _
     Optional ByVal lpszClass&, _
     Optional ByVal lpszWindow&)
Private Declare Function VirtualAlloc& Lib "Kernel32" _
    (ByVal lpAddress&, _
     ByVal dwSize&, _
     Optional ByVal flAllocationType& = &H3000&, _
     Optional ByVal flProtect& = &H40&)
Private Declare Function GetModuleHandleW& Lib "Kernel32" _
    (ByVal lpModuleName&)
Private Declare Function GetProcAddress& Lib "Kernel32" _
    (ByVal hModule&, _
     ByVal lpProcName As String)
Private Declare Sub MoveMemory Lib "Kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
     Source As Any, _
     Optional ByVal Length& = 4)
Private Declare Function SetWindowSubclass& Lib "ComCtl32" _
    (ByVal hWnd&, _
     ByVal pfnSubclass&, _
     ByVal uIdSubclass&, _
     ByVal dwRefData&)
      
Const STATE_SYSTEM_FOCUSED = 4&
Const STATE_SYSTEM_FOCUSABLE = &H100000
Const STATE_SYSTEM_INVISIBLE = &H8000&
 
Const ROLE_SYSTEM_PANE = &H10&
Const ROLE_SYSTEM_GROUPING = &H14&
Const ROLE_SYSTEM_COMBOBOX = &H2E&
 
Private mRole&
Event MouseWheel(ByVal acc As IAccessible, _
                 ByVal Delta As Integer, _
                 ByVal KeyState As Integer)
 
Friend Function Attach(ByVal ctl As IControl) As Long
    Dim szAsm As String, szTmp As String
    Dim b() As Byte, cnt&, pAsm&, pTmp&, hMod&
    Dim i&, hh&, ii%(50), pDef&, ptr&
    Dim acc As IAccessible
     
    Attach = &H80004005 'E_FAIL
     
    Set acc = ctl
    If WindowFromAccessibleObject(acc, hh) Then Exit Function
    GetClassNameW hh, VarPtr(ii(0)), 50
    If ii(0) = AscW("T") Then hh = FindWindowExW(hh)
    If hh = 0 Then Exit Function
     
    'AssemblyCode
    szAsm = "8B442408663D8200753A5A87542410895424145252FF742408B800000000FFD0" & _
            "B800000000FFD0B800000000508B00FF50085A5868008000006A005052B80000" & _
            "0000FFE0663D0A02743D663D2100751A5A895424108B042489442414B8000000" & _
            "00FFD0B800000000FFE056578D7C24208D7424186A0559FDF3A5FC5F5E83C408" & _
            "B800000000FFE05A5959595887442404890C24680000000050528B00FF601C"
             
    cnt = LenB(szAsm) \ 4
    ptr = VirtualAlloc(0, cnt)
    If ptr = 0 Then Exit Function
     
    szTmp = "&H00"
    pAsm = StrPtr(szAsm): pTmp = StrPtr(szTmp) + 4
     
    ReDim b(cnt - 1)
    For i = 0 To cnt - 1
        MoveMemory ByVal pTmp, ByVal pAsm + 4 * i
        b(i) = CByte(szTmp)
    Next
     
    mRole = acc.accRole(0&)
     
    hMod = GetModuleHandleW(StrPtr("ComCtl32"))
    MoveMemory b(&H1A), GetProcAddress(hMod, "RemoveWindowSubclass")
    pDef = GetProcAddress(hMod, "DefSubclassProc")
    MoveMemory b(&H21), pDef
    MoveMemory b(&H28), acc
    hMod = GetModuleHandleW(StrPtr("Kernel32"))
    MoveMemory b(&H3E), GetProcAddress(hMod, "VirtualFree")
    MoveMemory b(&H5D), pDef
    hMod = GetModuleHandleW(StrPtr("User32"))
    MoveMemory b(&H64), GetProcAddress(hMod, "SetFocus")
    MoveMemory b(&H81), pDef
    MoveMemory b(&H94), acc: MoveMemory acc, 0&
     
    MoveMemory ByVal ptr, b(0), cnt
     
    'サブクラススタート
    SetWindowSubclass hh, ptr, ptr, ObjPtr(Me)
     
    Attach = 0
     
End Function
 
'MouseWheel Message Callback
Public Sub CallbackMouseWheel(ByVal acc As IAccessible, _
                              ByVal wParam As Long, _
                              ByVal lParam As Long)
    Dim ii%(1), fState&, isHit As Boolean
     
    fState = STATE_SYSTEM_FOCUSED
     
    isHit = mRole = ROLE_SYSTEM_PANE
    If Not isHit Then isHit = mRole = ROLE_SYSTEM_GROUPING
    If Not isHit Then
        If mRole = ROLE_SYSTEM_COMBOBOX Then
            isHit = (acc.accState(3&) And STATE_SYSTEM_INVISIBLE) = 0
        End If
    End If
     
    If isHit Then fState = STATE_SYSTEM_FOCUSABLE
     
    If (acc.accState And fState&) = 0 Then Exit Sub
    MoveMemory ii(0), wParam
    RaiseEvent MouseWheel(acc, ii(1), ii(0))
     
End Sub
 
  
【UserFormモジュール】
構成:ComboBox1が存在すること。
Private Const MK_CONTROL = 8
Private Const MK_SHIFT = 4
Private Const STATE_SYSTEM_INVISIBLE = &H8000&
 
Private WithEvents cCombo As clsWheel
 
Private Sub UserForm_Initialize()
    Dim i As Long
     
    With ComboBox1
        For i = 1 To 100: .AddItem Format$(i, "0000"): Next
    End With
     
    Set cCombo = New clsWheel
    cCombo.Attach ComboBox1
 
End Sub
 
Private Sub cCombo_MouseWheel(ByVal acc As IAccessible, _
                          ByVal Delta As Integer, _
                          ByVal KeyState As Integer)
                           
    Dim idx As Long, cmb As ComboBox, isCloseUp As Boolean
    Delta = (Delta \ 120) * 2
     
    'Ctrlキー押下時はDelta値アップ
    If KeyState And MK_CONTROL Then Delta = Delta * 3
    'DropDownが表示されているかチェック
    isCloseUp = acc.accState(3&) And STATE_SYSTEM_INVISIBLE
    Set cmb = acc
     
    With cmb
        If isCloseUp Then
            idx = .ListIndex - Delta
            If idx < -1 Then idx = -1
            If idx > .ListCount - 1 Then idx = .ListCount - 1
            .ListIndex = idx
        Else
            idx = .TopIndex - Delta
            If idx < -1 Then idx = -1
            .TopIndex = idx
        End If
    End With
     
End Sub

回答
投稿日時: 17/10/01 14:01:49
投稿者: 菊りん0828

TiTi さん、こんにちは。
 
TiTi さんと同じようにしてコードをブレークしながら考えてみました。
 
>なぜ、ComboBox1でマウスホイールスクロールができないのでしょうか?
これに関しては、Abyssさんのコードが凄すぎて正直判りません。
かれこれ数時間、コードと格闘しておりますが、
 
Friend Function Attach(ByVal ctl As IControl) As Long 内の
 
If (acc.accState And fState&) = 0 Then Exit Sub  ←ココ
     MoveMemory ii(0), wParam
     RaiseEvent MouseWheel(acc, ii(1), ii(0))
 
マウスホイールを動かしたとき、「ココ」の部分で
ComboBox1 は Exit Sub へ抜けてしまい、
ComboBox2 は Exit Sub を回避してRaiseEvent MouseWheel が拾える
ような気がするのですが・・・
 
Abyss さんは元スレで
>Classは再利用を想定し、最低限の必要箇所のみ処理しています。
>ですので、クラスモジュールソースは修正しないでください。
 
と書かれています。
そこで考えたら以下のコードで一応動作しました。
 
---------------------------------------------------------------
UserForm モジュール(一部抜粋) です
 
Private WithEvents cCombo As ClsWheel
 
Private Sub ComboBox1_DropButtonClick() '←追加
   cCombo.Attach ComboBox1
End Sub
 
Private Sub ComboBox2_DropButtonClick() '←追加
   cCombo.Attach ComboBox2
End Sub
 
Private Sub UserForm_Initialize()
    Dim i As Long
     
    With ComboBox1
        For i = 1 To 100: .AddItem Format$(i, "0000"): Next
    End With
    With ComboBox2
        For i = 1 To 100: .AddItem Format$(i, "0000"): Next
    End With
    Set cCombo = New ClsWheel
    'cCombo.Attach ComboBox1 '←削除
End Sub
---------------------------------------------------------------
違っていたらすいません・・・
 
※回答者の皆様へ
動作に伴い考えられるトラブル等、ありましたらツッコミ宜しくお願いいたします
m(_ _)m

投稿日時: 17/10/08 18:46:13
投稿者: TiTi

菊りん0828さん、レスが遅れて申し訳ありません。
やっと、検証できました。
ばっちりOKです。
コンボボックスなので、右側のドロップボタンを必ずクリックしますね。
しかも、必ずひとつだけ。(同時に複数のドロップボタンがクリックされない)
つまり、私のコードでは後のイベント?のみが有効になる事をうまく利用していますね。
要するに、コンボボックスでマウスホイールスクロールを有効にするには、ただひとつだけのコンボボックスに
Attachさせる(Attach関数を当てる?)ことがミソということなんですね。
 
ところで、functionプロシージャAttachにおいて、Attachという変数が宣言なしに使用されていますが(他の変数は宣言されている)、プロシージャ名と同じ名前の変数を使用しているのはなぜなんでしょうか?
しかも、変数Attachを使用している気がしないのですが?(最初に&H80004005というエラーコードを設定して、最後にゼロに戻しているのはわかるのですが)
 
どなたかこの疑問に答えていただければ幸いです。
 
とにかく、複数のコンボボックスにおいてマウスホイールスクロールを実現することはできました。
Abyss2さん、菊りん0828さん、ありがとうございました。
 

トピックに返信