Excel VBA トグルボタンのコントロール

質問

お世話になります。
現在、ユーザーフォームにて管理アプリもどきを作成しているのですが、
以下の様な動作を行うことが可能かどうか、
また可能であればどのような方法があるのかをご教授ください。

//////////////////////////////////////////////////////////

フォーム上に、トグルボタンを複数個配置します。
例として、下図をトグルボタンを５つ配置したものと仮定します。
Valueプロパティは全てFalseを初期値とします。

　□□□□□

左から２つ目のトグルボタン上でマウスクリックし、
そのままクリックを押し込んだままの状態にします。
この時点で、２つ目のボタンのValueプロパティをTrueに変更します。

　□■□□□
　　 ↑クリック（押し込んだまま）

クリックを押し込んだまま、マウスを右に移動させます。
左から３つ目、４つ目のボタン上にカーソルがきた時点で
３つ目、４つ目のValueプロパティをTrueに変更します。

　□■■■□
　　　　 　↑クリック（押し込んだまま）

左から４つ目のトグルボタン上でクリックを離します。
クリックされていない状態でマウスカーソルが上に乗っても
Valueの変更は行われません。

//////////////////////////////////////////////////////////

MouseMoveを試してみましたが、ドラッグ中は処理が発生しないようなので
どうしたものか困ってしまいました。
ご助力、よろしくお願い致します。

回答No.3

mitarashi

#1-2ですが、ひょっとしてUserForm_MouseDownなら、OnTimeのお世話にならなくてもいけるのではと思ってトライしてみるとOKでした。おかげで動作も軽快になりました。ついでに物好きな御仁のために若干のバグフィックス（誤動作防止）もしてあります。
☆標準モジュール
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetActiveWindow Lib "user32" () As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Public Type POINTAPI
X As Long
Y As Long
End Type

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Const VK_LBUTTON = &H1 '[LeftClick]
Public Const VK_RBUTTON = &H2 '[RightClick]

Sub test()
UserForm1.Show
End Sub

☆UserForm1モジュール
Dim hWnd As Long
Private myToggle() As MSForms.ToggleButton
Private myRect() As RECT
Private initialColor As Long
'UserFormのハンドル取得。 ScreenToClient APIで使用。
Private Sub UserForm_Activate()
hWnd = GetActiveWindow()
End Sub

Private Sub UserForm_Initialize()
Dim myControl As Control
Dim scaleFactor As Single

scaleFactor = 96 / 72
'配列の添え字0の要素は使わない
ReDim myToggle(0 To 0)
ReDim myRect(0 To 0)
For Each myControl In Me.Controls
If TypeName(myControl) = "ToggleButton" Then
myControl.Enabled = False
myControl.Caption = ""
ReDim Preserve myToggle(0 To UBound(myToggle) + 1)
ReDim Preserve myRect(0 To UBound(myRect) + 1)
Set myToggle(UBound(myToggle)) = myControl
With myRect(UBound(myRect))
.Left = CLng(myControl.Left * scaleFactor)
.Top = CLng(myControl.Top * scaleFactor)
.Right = CLng((myControl.Left + myControl.Width) * scaleFactor)
.Bottom = CLng((myControl.Top + myControl.Height) * scaleFactor)
End With
End If
Next
initialColor = myToggle(1).BackColor
End Sub

'Private Sub UserForm_Click()だと、ボタンを離さないとEventが発生しない
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim tempToggle As MSForms.ToggleButton
Dim initialState As Boolean
Dim toggleNo As Long, currentToggleNo As Long

'最初のクリック箇所を保持
If Button <> VK_LBUTTON Then Exit Sub
currentToggleNo = getToggleNo()

With myToggle(currentToggleNo)
initialState = .Value
.Value = Not (initialState)
.BackColor = IIf(initialState, initialColor, vbBlue)
End With
'無限ループでマウスのモニタ
Do
DoEvents: DoEvents: DoEvents
Sleep 10
toggleNo = getToggleNo
If toggleNo <> 0 Then
Set tempToggle = myToggle(toggleNo)
With tempToggle
.Value = Not (initialState)
.BackColor = IIf(initialState, initialColor, vbBlue)
End With
Set tempToggle = Nothing
End If
'マウスの左ボタンを離すまでループ
Loop While GetAsyncKeyState(VK_LBUTTON)
End Sub

'マウスの存在する位置のトグルボックスのNoを取得。取得失敗は0を戻す。
Private Function getToggleNo() As Long
Dim pos As POINTAPI
Dim ret As Long
Dim i As Long

'Screen座標→Client座標に変換。RECT配列内の値はUserForm座標→Client座標に変換済み。
GetCursorPos pos
ret = ScreenToClient(hWnd, pos)
For i = 1 To UBound(myRect)
With myRect(i)
If (pos.X >= .Left) And (pos.X <= .Right) And (pos.Y >= .Top) And (pos.Y <= .Bottom) Then
getToggleNo = i
Exit Function
End If
End With
Next i
getToggleNo = 0
End Function

回答No.2

mitarashi

#1です。
だいぶ苦労の果てに動いたので、思わず投稿してしまいましたが、本来デバッグを容易にするために動的に配置したトグルボタンを対象にしていたのでした。既設トグルボタンを対象とする様に改造しました。一部のプロシージャの置き換え程度で可能です。なお、マウスの動かし初めで漏らしてしまう現象は、最初のトグルボタンの状態が変わるまで一呼吸待つと良い事がわかりました。ご参考まで。
変更部分のみ記載します。
☆　標準モジュール　toggleControlModule
'構造体追加
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

☆ UserForm1モジュール
'変数の追加
Private myRect() As RECT
Private initialColor As Long

'関数の置き換え

Private Sub UserForm_Initialize()
Dim myControl As Control
Dim scaleFactor As Single

scaleFactor = 96 / 72
'配列の添え字0の要素は宣言しているだけで使っておりません
'都度添え字の最大を求めるのは誉められないと思いますが．．．
ReDim myToggle(0 To 0)
ReDim myRect(0 To 0)
'既設トグルボタンと、その座標を配列に取り込む
For Each myControl In Me.Controls
If TypeName(myControl) = "ToggleButton" Then
myControl.Enabled = False
myControl.Caption = ""
ReDim Preserve myToggle(0 To UBound(myToggle) + 1)
ReDim Preserve myRect(0 To UBound(myRect) + 1)
Set myToggle(UBound(myToggle)) = myControl
With myRect(UBound(myRect))
.Left = myControl.Left * scaleFactor
.Top = myControl.Top * scaleFactor
.Right = (myControl.Left + myControl.Width) * scaleFactor
.Bottom = (myControl.Top + myControl.Height) * scaleFactor
End With
End If
Next
initialColor = myToggle(1).BackColor
End Sub

'少しは高速かと思い、座標の照合はRECT構造体と行う様にしてみました
Private Function getToggleNo() As Long
Dim pos As POINTAPI
Dim ret As Long
Dim i As Long

GetCursorPos pos
ret = ScreenToClient(hWnd, pos)
For i = 1 To UBound(myRect)
With myRect(i)
If (pos.X >= .Left) And (pos.X <= .Right) And (pos.Y >= .Top) And (pos.Y <= .Bottom) Then
getToggleNo = i
Exit Function
End If
End With
Next i
getToggleNo = 0
End Function

'おまけ　トグルボタンの色を変える
Public Sub ontimesub()の中で、
.Value = Not (initialState)
のところに、下記を追加する。
.BackColor = IIf(initialState, initialColor, vbBlue)

回答No.1

mitarashi

もうご覧になっていないかもしれませんが、それらしい動作が実現出来たのでUpしておきます。
自分でも来週には分からなくなるかも知れないので珍しくコメントを沢山入れました．．．
ToggleButtonのイベントを使うとうまくいかなかったので、DisableにしてUserFormのイベントで操作しています。
押し込んでない状態のボタンからスタートすると、通過したボタンを押し込み、押し込んだボタンからスタートすると逆の動作をします。特に動かし初めは、あまり速くマウスを動かすと漏らしますのでご注意下さい。
実用的ではないと存じますが、話の種にどうぞ。

☆標準モジュール　toggleControlModule
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetActiveWindow Lib "user32" () As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Public Type POINTAPI
X As Long
Y As Long
End Type

Public Const VK_LBUTTON = &H1 '[LeftClick]
Public Const VK_RBUTTON = &H2 '[RightClick]

Private nextTriggerTime As Date

Sub test()
UserForm1.Show
End Sub

'UserForm側でApplication.Ontimeが実行出来ないので仲立ちをする
Public Sub setOnTime()
nextTriggerTime = [now()+"00:00:00.50"]
Application.OnTime nextTriggerTime, "onTimer"
End Sub

Public Sub onTimer()
UserForm1.ontimesub
End Sub

☆UserForm1モジュール　toggleButtonは動的に設置するので、コントロールは配置無用
Dim hWnd As Long
Private myToggle() As MSForms.ToggleButton
Private xframe As Single, yframe As Single
Private myStartToggle As Long

Const BUTTONCOUNT As Long = 15
Const COLUMNCOUNT As Long = 5
Const SIDELENGTH As Long = 40

Private Sub UserForm_Initialize()
Dim i As Long

With Me
xframe = .Width - .InsideWidth
yframe = .Height - .InsideHeight
End With

ReDim myToggle(1 To BUTTONCOUNT)
For i = 1 To BUTTONCOUNT
Set myToggle(i) = Controls.Add("Forms.ToggleButton.1")
With myToggle(i)
'UserFormのイベントを用いるためにtoggleButtonはDisableにする。値の変更は可能。
.Enabled = False
.Width = SIDELENGTH
.Height = SIDELENGTH
.Left = SIDELENGTH * ((i - 1) Mod COLUMNCOUNT)
.Top = SIDELENGTH * ((i - 1) \ COLUMNCOUNT)
End With
Next i
With Me
.Width = xframe + SIDELENGTH * COLUMNCOUNT
.Height = yframe + SIDELENGTH * (BUTTONCOUNT \ COLUMNCOUNT)
End With
End Sub

Private Sub UserForm_Activate()
hWnd = GetActiveWindow()
End Sub

'Private Sub UserForm_Click()だと、ボタンを離さないとEventが発生しないらしい
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'最初のクリック箇所を保持
Me.startToggle = getToggleNo()
'イベントを直ぐに抜けるために、次の処理はApplication.OnTimeで起動する
'UserFormからは直には使えないので、標準モジュールに仲立ちをしてもらう
toggleControlModule.setOnTime
End Sub

Public Sub ontimesub()
Dim tempToggle As MSForms.ToggleButton
Dim initialState As Boolean

With myToggle(Me.startToggle)
initialState = .Value
'状態変更の前にEnabled=True,変更後にEnabled=Falseにする必要があると考えたが無くてもOKだった
.Value = Not (initialState)
End With
Do
DoEvents: DoEvents: DoEvents
Sleep 10
Set tempToggle = myToggle(getToggleNo())
With tempToggle
.Value = Not (initialState)
End With
Set tempToggle = Nothing
'マウスの左ボタンを離すまでループ
Loop While GetAsyncKeyState(VK_LBUTTON)
End Sub

Private Function getToggleNo() As Long
Dim pos As POINTAPI
Dim ret As Long
Dim toggleId As Long

GetCursorPos pos
ret = ScreenToClient(hWnd, pos)
With pos
'UserForm座標系の値に戻す
.X = .X * 72 / 96
.Y = .Y * 72 / 96
getToggleNo = (.X \ SIDELENGTH) + (.Y \ SIDELENGTH) * COLUMNCOUNT + 1
End With
End Function

Public Property Let startToggle(toggleNo As Long)
myStartToggle = toggleNo
End Property

Public Property Get startToggle() As Long
startToggle = myStartToggle
End Property