お世話になります。
現在、ユーザーフォームにて管理アプリもどきを作成しているのですが、
以下の様な動作を行うことが可能かどうか、
また可能であればどのような方法があるのかをご教授ください。
//////////////////////////////////////////////////////////
フォーム上に、トグルボタンを複数個配置します。
例として、下図をトグルボタンを5つ配置したものと仮定します。
Valueプロパティは全てFalseを初期値とします。
□□□□□
左から2つ目のトグルボタン上でマウスクリックし、
そのままクリックを押し込んだままの状態にします。
この時点で、2つ目のボタンのValueプロパティをTrueに変更します。
□■□□□
↑クリック(押し込んだまま)
クリックを押し込んだまま、マウスを右に移動させます。
左から3つ目、4つ目のボタン上にカーソルがきた時点で
3つ目、4つ目のValueプロパティをTrueに変更します。
□■■■□
↑クリック(押し込んだまま)
左から4つ目のトグルボタン上でクリックを離します。
クリックされていない状態でマウスカーソルが上に乗っても
Valueの変更は行われません。
//////////////////////////////////////////////////////////
MouseMoveを試してみましたが、ドラッグ中は処理が発生しないようなので
どうしたものか困ってしまいました。
ご助力、よろしくお願い致します。
A 回答 (3件)
- 最新から表示
- 回答順に表示
No.3
- 回答日時:
#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
- 回答日時:
#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
- 回答日時:
もうご覧になっていないかもしれませんが、それらしい動作が実現出来たので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
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) VBA 画面上のカーソルに文字数字を入力するコードを教えて下さい 1 2022/10/30 10:31
- Windows 8 動画の再生とタイトルの変更方法を教えてください。 3 2022/08/01 14:51
- Windows 10 (緊急)windowsのタスクバーやアプリ?が反応しない 3 2023/03/28 05:03
- Visual Basic(VBA) VBAのトグルボタンでのマクロについて質問です 3 2022/10/10 17:23
- Visual Basic(VBA) 3つのプロシージャをまとめたら実行時エラー発生で対応不能 6 2022/05/17 01:47
- Access(アクセス) アクセス 意図せずサブプロシージャを移動してしまうのを止めたい 1 2022/09/02 09:19
- JavaScript 入力フォームの javascript で メールアドレスの正規チェックをを行い、ボタンをクリックして 2 2022/04/27 16:06
- Windows 10 Windows10の不具合(Critical Process Died) 9 2022/04/19 21:11
- その他(データベース) Accessフォームからパラメーターで表示したレコードを指定のExcelのセルへ転送する方法について 2 2022/08/22 18:04
- Visual Basic(VBA) 【再々投稿】VBAのプログラムで動作しなくて困っています 8 2022/10/14 09:06
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Dellマウスの組み立て方
-
マウスを左クリックしたとき、...
-
ロジクールのマウスのサイドボ...
-
マウスの反応がよすぎる・・・
-
C# DataGridView の列ヘッダー...
-
マウスの左クリックがホールド...
-
マウスの左クリックを長押しし...
-
クリック連打ソフトの作り方
-
マウスの使いすぎで人差し指が...
-
パソコンにつぃて
-
レーザーマウスのポインタだけ...
-
クリック音のしない、DAISOのワ...
-
Razer DeathAdder 光らない
-
マウスの中央ボタンが勝手にク...
-
AutoHotKey 「Tabを押し続ける ...
-
PS4 フォートナイト 直差しの話...
-
PCマインクラフト 左クリック
-
apex中に戦闘画面でマウスが動...
-
ホイールが押しやすいマウス
-
1台のPCに2台のワイヤレスマウ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
マウスを左クリックすると、右...
-
ロジクールのマウスのサイドボ...
-
⚪︎マウスがクリック出来なくな...
-
カチカチとクリック音がするマ...
-
ロジクールのマウスM570の...
-
マウスの操作がおかしい
-
マウスの左クリックがホールド...
-
マウスの左クリックを長押しし...
-
マウスを左クリックしたとき、...
-
マウスで左クリックすると範囲...
-
Dellマウスの組み立て方
-
マウスの反応がよすぎる・・・
-
最近になってマウスホイールを...
-
マウスの左クリックで右クリッ...
-
クリックがボタンを離すときに...
-
マウスをクリックすると出てく...
-
C# DataGridView の列ヘッダー...
-
レーザーマウスのポインタだけ...
-
マウスをクリックすると、たま...
-
右クリック固定マウスを探して...
おすすめ情報