[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ユーザーフォームの全ての種類のコントロールに同じイベントを割り付ける』（田吾作）
クラスモジュールを使用し、ユーザーフォーム上の全てのコントロールに同じイベントを割り付けようとしています。
現在は、ラベル限定のコードになっています。このコードはラベル上でマウスを動かすと、イベントが起動します。 これはうまくいっています。
'ユーザーフォーム
Dim con() As New concls
Private Sub UserForm_Initialize()
Dim cnt As Integer
Dim mycon As Object
cnt = -1
For Each mycon In Me.Controls
If TypeName(mycon) = "Label" Then
cnt = cnt + 1
ReDim Preserve con(0 To cnt)
Set con(cnt).ctrl = mycon
End If
Next mycon
End Sub
'クラス/クラス名：concls
Public WithEvents ctrl As MSForms.Label
Private Sub ctrl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) MsgBox ctrl.Name End Sub
これを全ての種類のコントロールで作動するようにしたいのです。 試しに↓のようにしましたがエラーになります。
>Public WithEvents ctrl As MSForms.Control これの >MSForms.Control がまずいようです。
実行時エラー '459' オブジェクトまたはクラスがこのイベントセットをサポートしていません
というエラーが表示されます。
全ての種類のコントロールに適用できるようにするにはどのように書き換えたらいいでしょうか？ ご教示お願いいたします。
なお、コントロールの種類ごとに別々のクラスを割り付けた場合はうまくいっています。
'ユーザーフォーム
Dim con() As New concls
Private Sub UserForm_Initialize()
Dim cnt As Integer
Dim mycon As Object
cnt = -1
For Each mycon In Me.Controls
cnt = cnt + 1
ReDim Preserve con(0 To cnt)
Set con(cnt).ctrl = mycon
Next mycon
End Sub
'クラス/クラス名：concls
Public WithEvents ctrl As MSForms.Control
Private Sub ctrl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) MsgBox ctrl.Name End Sub
なぜこんなことをしたいのか、と言いますと、↓のurlのユーザーフォーム上でドラッグしてユーザーフォームを移動する、という ことしたいのです。
ユーザーフォーム自体および個別のコントロールのイベントに記述する方法ではうまくいってますが、全てのコントロールのイベント に記述するのが面倒だからです。 http://hatenachips.blog34.fc2.com/blog-entry-418.html
＜ 使用 Excel：Excel2007、使用 OS：WindowsVista ＞
どうすれば、目的のテーマが達成できるか、おもしろそうなので、私も時間を見つけてチャレンジしてみたいと思いますが、それはさておき。
たしかに、拒否されますね。種別を特定しないオブジェクトに対しては、WithEvents の規定が不可能という そういう仕様ではないでしょうか？
WithEvents ではなく 通常のオブジェクトとして規定して、たとえば msg といったメソッドを
Sub msg()
MsgBox ctrl.Name
End Sub
として、ユーザーフォーム側から クラスオブジェクト.msg としてやりますと、そのオブジェクト名が表示されますので As MsForms.Control という記述そのものは、間違ってはいないのですがね。
ところで、仮に、この Set が拒否されず、ちゃんと機能したとします。 でも、このコントロールがサポートするイベント（ＶＢＥ画面の左上のボックスで ctrlを選んだ時に右上のボックスに表示されるイベント）は
AftrUpdate,BeforeUpdate,Enter,Exit のみですよね。なので、MouseMove は使いたくても使えないでしょうね。 (その前に、Set 自体が拒否されるわけですが）
一方、これまでクラスで、たとえばテキストボックスに対して通常のコード記述では BeforeUpdate 等のイベントを使いたくても使えず 特別なコードを準備して対応していたわけですけど、つまり、クラスでのイベント処理には 通常の方法ではBeforeUpdate等は使えないと思っておりましたので 今回、この右上のイベントに、これらがでてきて、びっくりしました。（でも Set できないので、いかんともしがたいですがね）
（β） 2015/08/21(金) 06:36
メカニズム的には 出来ませんよね！！ いくつかあるコントロールのイベントプロシジャーをどこかで 記述しなければなりません。
が、ユーザーフォームモジュール側でそれらしい記述を可能にすることはできます。 再利用可能になるように作ってしまえば 、この様な事象が別で発生しても 簡単に実現できます。
そのロジック自体は、何度か体験すれば 理解出来ると思いますが、 それを作るのは結構大変です。 疑似からの脱却 を利用されたらよいと思います。
http://www.h3.dion.ne.jp/~sakatsu/Bpca_Common.htm#C2CP
Bpca_Class_V20.zip
利用方法や プロパティ、メソッドの使用方法は 上記サイトを参考にしてください。
まずは、試してみてください。
（ichinose） 2015/08/21(金) 07:15
直接の回答ではないのですが。
おもしろそうなのでイベント処理ではなく、マウスカーソルの場所を追いかけながら、それがユーザーフォームのWindow領域内なら その動きの分、ユーザーフォームを移動させるコードを書いてみて試して、気が付いたんですが。
現在のMouseMoveイベントでの処理コードが完成したとします。
そうすると・・・
マウスをユーザーフォームにもっていきます。最初は UserFormのMouseMoveに引っかかると思います。 で、その瞬間に、ユーザーフォームをマウスの動きに合わせて「正しく移動」させると、マウスの位置は やはり他のコントロールではなく、最初にユーザーフォームにマウスが入った場所、つまり、「相対的に」みれば マウスポジションとユーザーフォームの位置関係は変わらない。
つまり、どれだけマウスを動かそうが、せっかく他のコントロールに仕掛けた MouseMove は発生しないですよねぇ・・・
動きとしては、ユーザーフォームの外側のどこかにマウスを当てて、ユーザーフォームを、そこから【押す】という感じではないでしょうかね。 （しかも【ひっぱる】動きはできない？）
（β） 2015/08/21(金) 10:15
βさん、ichinoseさん、ご回答ありがとうございます。
ご紹介いただきました角田さんのHPからBpca_Class_V20.zipをダウンロード して展開してみました。
標準モジュール/modBpcaConstの
Public Const BPCA2_Except_MouseM As Long = BPCA2_All - BPCA2_MouseMove
を
Public Const BPCA2_Except_MouseM As Long = BPCA2_All
に変えることで ユーザーフォーム/frmBpca1の上半分の部分でコマンドボタンやテキストボックス、ラベルで MousMoveイベントが作動することが確認できました。
コード全体を理解するのには時間がかかりそうですが勉強してみます。 （田吾作） 2015/08/21(金) 17:30
全く意味のない遊びです。 イベント処理は使わずマウスの場所をチェックしています。ただ、いわゆる MouseMoveの状態だと制御が (βには）荷が重いので、MouseDownの状態でのドラッグに反応させます。 したがって、実際には、使えない代物ですね。（クリックイベント等はもちろん、実際のものには存在するでしょうから）
まぁ、遊びということで。ユーザーフォームの任意の場所でMouseDownさせたまま移動させます。
ユーザーフォームモジュール
Private Sub UserForm_Activate()
Application.OnTime Now(), "Moving"
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Fin
End Sub
標準モジュール
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
Declare Function GetCursorPos Lib "User32" (lpPoint As CurPT) As Long
Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As Object, ByRef phwnd As Long) As Long
Declare Function GetWindowRect Lib "User32" (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function MoveWindow Lib "User32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Type CurPT
x As Long
y As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Dim DoLoop As Boolean
Sub Moving()
Dim rtn As Long
Dim hWnd As Long
Dim rw As RECT
Dim cp As CurPT
Dim newL As Long
Dim newT As Long
Dim exX As Long
Dim exY As Long
Dim flag As Boolean
Dim w As Long
Dim h As Long
DoLoop = True
WindowFromAccessibleObject UserForm1, hWnd
Do While DoLoop
rtn = GetAsyncKeyState(&H1) '左クリック
If rtn <> 0 Then
'フォームの領域取得
GetWindowRect hWnd, rw
'現在のマウス位置の取得
GetCursorPos cp
flag = False
If cp.x >= rw.Left Then
If cp.x <= rw.Right Then
If cp.y >= rw.Top Then
If cp.y <= rw.Bottom Then
flag = True
If exX = 0 And exY = 0 Then
exX = cp.x
exY = cp.y
Else
newL = rw.Left + cp.x - exX
newT = rw.Top + cp.y - exY
'フォームウィンドウの位置変更
MoveWindow hWnd, newL, newT, rw.Right - rw.Left, rw.Bottom - rw.Top, 1
exX = cp.x
exY = cp.y
End If
End If
End If
End If
If Not flag Then
exX = 0
exY = 0
End If
End If
Else
exX = 0
exY = 0
End If
DoEvents
Sleep 10
Loop
End Sub
Sub Fin()
DoLoop = False
End Sub
（β） 2015/08/21(金) 17:55
↑ 操作が窮屈になりますが、Shift + 右クリック でつまんで動かせば、いわゆるクリックイベントとのバッティングはなくなりました。 もちろん、GetAsyncKeyState(&H1) のチェックの代わりに GetAsyncKeyState(&H2) と GetAsyncKeyState(&H10) のチェックを使いますが。
追記 20:41 通常の左クリックでコマンドボタン等をつかんで移動させても、
考えてみれば、コマンドボタン等のクリックイベントとバッティングするわけではなく
フォーム自体は移動しても、マウスを離したときに、イベントが発生するので
使えるかも。（実際にやってみて違和感はなかったので）
（β） 2015/08/21(金) 19:41
まだよくテストしてませんが、βさんのコードに少し手を加えて コマンドボタンクリックでフラグの上げ下げをしてユーザーフォーム をドラッグ＆ドロップで移動するのを制御するようにしてみました。
myflgがTrueのときにユーザーフォームが移動でき、Falseのときはユーザーフォーム をドラッグ＆ドロップでは移動しない、というようにしてみました。
'標準モジュール ↓付加 Public myflg As Boolean
Sub Moving()
MoveWindow hWnd, newL, newT, rw.Right - rw.Left, rw.Bottom - rw.Top, 1 ↑を↓に変更 If myflg <> False Then MoveWindow hWnd, newL, newT, rw.Right - rw.Left, rw.Bottom - rw.Top, 1
'ユーザーフォーム Private Sub CommandButton1_Click() myflg = Not myflg 'クリックするごとにフラグを上げ下げ End Sub
Private Sub UserForm_Initialize() myflg = True End Sub
（田吾作） 2015/08/21(金) 22:34
↑の私の変更したものではちょっと不具合が出たので下のように変えてみました。
'ユーザーフォーム
Private Sub CommandButton1_Click() Dim mycon As Object myflg = Not myflg Call conseigyo End Sub
Private Sub UserForm_Initialize() myflg = True Call conseigyo End Sub
Private Function conseigyo()
Dim mycon As Object
If myflg = False Then 'myflgがFalseだったらコントロールを使えないようにする
For Each mycon In Me.Controls
On Error Resume Next
If mycon.Name <> Me.Controls("CommandButton" & 1).Name Then mycon.Enabled = False 'CommandButon1は常に使えるようにする
On Error GoTo 0
Next mycon
Else 'myflgがTrueだったらコントロールを使えるようにする
For Each mycon In Me.Controls
On Error Resume Next
mycon.Enabled = True
On Error GoTo 0
Next mycon
End If
End Function
'標準モジュール
If myflg <> False Then MoveWindow hWnd, newL, newT, rw.Right - rw.Left, rw.Bottom - rw.Top, 1 ↑を↓に変更 If myflg = False Then MoveWindow hWnd, newL, newT, rw.Right - rw.Left, rw.Bottom - rw.Top, 1 （田吾作） 2015/08/21(金) 22:59
複数のユーザーフォームで使えるようにしてみました。
'ユーザーフォーム
'UserForm1
Private Sub CommandButton1_Click()
Dim mycon As Object
myflguf = Not myflguf
Call conseigyo(Me.Controls("CommandButton1"))
End Sub
Private Sub CommandButton2_Click() MsgBox "xx" End Sub
Private Sub CommandButton3_Click() 'Me.Hide Unload Me UserForm2.Show 0 End Sub
Private Sub UserForm_Activate() Application.OnTime Now(), "Moving" End Sub
Private Sub UserForm_Initialize()
Set myuf = Me
myflguf = True
Call conseigyo(Me.Controls("CommandButton1"))
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Fin End Sub
'UserForm2
Private Sub CommandButton1_Click()
Dim mycon As Object
myflguf = Not myflguf
Call conseigyo(Me.Controls("CommandButton1"))
End Sub
Private Sub CommandButton2_Click() MsgBox "xx" End Sub
Private Sub CommandButton3_Click() 'Me.Hide Unload Me UserForm1.Show 0 End Sub
Private Sub UserForm_Activate() Application.OnTime Now(), "Moving" End Sub
Private Sub UserForm_Initialize()
Set myuf = Me
myflguf = True
Call conseigyo(Me.Controls("CommandButton1"))
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Fin End Sub
'標準モジュール
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long Declare Function GetCursorPos Lib "User32" (lpPoint As CurPT) As Long Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As Object, ByRef phwnd As Long) As Long Declare Function GetWindowRect Lib "User32" (ByVal hWnd As Long, lpRect As RECT) As Long Declare Function MoveWindow Lib "User32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long Type CurPT
x As Long
y As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Dim DoLoop As Boolean
Public myflguf As Boolean Public myuf As UserForm
Sub Moving()
Dim rtn As Long
Dim hWnd As Long
Dim rw As RECT
Dim cp As CurPT
Dim newL As Long
Dim newT As Long
Dim exX As Long
Dim exY As Long
Dim flag As Boolean
Dim w As Long
Dim h As Long
DoLoop = True
WindowFromAccessibleObject myuf, hWnd
Do While DoLoop
rtn = GetAsyncKeyState(&H1) '左クリック
If rtn <> 0 Then
'フォームの領域取得
GetWindowRect hWnd, rw
'現在のマウス位置の取得
GetCursorPos cp
flag = False
If cp.x >= rw.Left Then
If cp.x <= rw.Right Then
If cp.y >= rw.Top Then
If cp.y <= rw.Bottom Then
flag = True
If exX = 0 And exY = 0 Then
exX = cp.x
exY = cp.y
Else
newL = rw.Left + cp.x - exX
newT = rw.Top + cp.y - exY
'フォームウィンドウの位置変更
If myflguf = False Then MoveWindow hWnd, newL, newT, rw.Right - rw.Left, rw.Bottom - rw.Top, 1
exX = cp.x
exY = cp.y
End If
End If
End If
End If
If Not flag Then
exX = 0
exY = 0
End If
End If
Else
exX = 0
exY = 0
End If
DoEvents
Sleep 10
Loop
End Sub
Public Function conseigyo(ByVal cmd As Object)
Dim mycon As Object
If myflguf = False Then
For Each mycon In myuf.Controls
On Error Resume Next
If mycon.Name <> cmd.Name Then mycon.Enabled = False
On Error GoTo 0
Next mycon
Else
For Each mycon In myuf.Controls
On Error Resume Next
mycon.Enabled = True
On Error GoTo 0
Next mycon
End If
End Function
Sub Fin() DoLoop = False End Sub （田吾作） 2015/08/22(土) 00:55
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.