| |
おはようございます。
>※Classでも、CPU全開の方法(Doevents回しっ放しでフォーカスのある所を
> 監視する）を取ればできるんでしょうがとてもお勧めできません。
実は、ずいぶん前に作ったのですが、私も業務には↑これを使う決心がつきません。
で、良い機会なので、皆さんに試して頂ければ、とコードを投稿します。
新規ブックにユーザーフォームだけ作成してください。
コントロールは、コードで作成しますから、配置しないで下さい。
ユーザーフォーム（Userform1）のモジュールに
'=============================================================
Option Explicit
Private txt1 As MSForms.TextBox
Private txt2 As MSForms.TextBox
Private txt3 As MSForms.TextBox
Private WithEvents btn As MSForms.CommandButton
Private WithEvents ev As Class1
'=============================================================
Private Sub btn_Click()
If ev.EvEnable(btn) = True Then 'ev_movectrlイベントは既に発生した
ActiveSheet.Cells(1, 1) = txt1.Value
ActiveSheet.Cells(1, 2) = txt2.Value
ActiveSheet.Cells(1, 3) = txt3.Value
txt1.SetFocus
End If
End Sub
'=============================================================
Private Sub ev_movectrl(f_ctrl As Object, n_ctrl As Object)
If Not n_ctrl Is Nothing Then
If TypeName(n_ctrl) = "TextBox" Then
n_ctrl.BackColor = &H80FFFF
End If
End If
If Not f_ctrl Is Nothing Then
If TypeName(f_ctrl) = "TextBox" Then
f_ctrl.BackColor = &HFFFFFF
End If
End If
End Sub
'=============================================================
Private Sub UserForm_Activate()
ev.stt_kanshi Me, True
End Sub
'=============================================================
Private Sub UserForm_Initialize()
With Me
.Width = 262
.Height = 248
Set txt1 = .Controls.Add("Forms.TextBox.1", , True)
With txt1
.Left = 18
.Top = 36
.Width = 204
.Height = 24
.Font.Size = 14
End With
Set txt2 = .Controls.Add("Forms.TextBox.1", , True)
With txt2
.Left = 18
.Top = 78
.Width = 204
.Height = 24
.Font.Size = 14
End With
Set txt3 = .Controls.Add("Forms.TextBox.1", , True)
With txt3
.Left = 18
.Top = 120
.Width = 204
.Height = 24
.Font.Size = 14
End With
Set btn = .Controls.Add("Forms.CommandButton.1", , True)
With btn
.Left = 156
.Top = 180
.Width = 66
.Height = 30
.Caption = "書き込み"
End With
End With
Set ev = New Class1
End Sub
'=============================================================
Private Sub UserForm_Terminate()
ev.stop_kanshi
Set ev = Nothing
End Sub
クラスモジュール（Class1）のモジュール
'================================================================
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private f_ctrl As Object
Private n_ctrl As Object
Private evc() As String
Private evc_cnt As Long
Private stopflag As Boolean
Event movectrl(f_ctrl As Object, n_ctrl As Object)
'================================================================
Sub set_ev_ctrlnm(ctrl As Object)
'イベント発生させるコントロールを指定する
ReDim Preserve evc(1 To evc_cnt + 1)
evc(evc_cnt + 1) = ctrl.Name
evc_cnt = evc_cnt + 1
End Sub
'================================================================
Function EvEnable(ctrl As Object) As Boolean
'本イベントの発生の有無を確認する
EvEnable = True
If Not f_ctrl Is ctrl Then EvEnable = False
End Function
'================================================================
Sub stt_kanshi(obj As Object, Optional f_eve As Boolean = False)
'監視開始
On Error Resume Next
Dim f_nm As String
Dim n_nm As String
Set f_ctrl = Nothing
If f_eve = False Then
Set f_ctrl = f_actrl(obj, f_nm)
End If
stopflag = False
Do While stopflag = False
Set n_ctrl = f_actrl(obj, n_nm)
If Not f_ctrl Is n_ctrl Then
If evchk(f_ctrl, n_ctrl) = True Then
RaiseEvent movectrl(f_ctrl, n_ctrl)
If Not n_ctrl Is Nothing Then
With n_ctrl
.SetFocus
End With
End If
Set f_ctrl = n_ctrl
Else
Set f_ctrl = n_ctrl
End If
End If
Sleep 100
DoEvents
Loop
End Sub
'================================================================
Private Function evchk(ctrl1 As Object, ctrl2 As Object) As Boolean
Dim cctrl(1 To 2) As Object
Dim ans As Variant
Set cctrl(1) = ctrl1
Set cctrl(2) = ctrl2
evchk = True
If evc_cnt > 0 Then
evchk = False
For idx = 1 To 2
If Not cctrl(idx) Is Nothing Then
ans = Application.Match(cctrl(idx).Name, evc(), 0)
If Not IsError(ans) Then
evchk = True
End If
End If
If evchk = True Then Exit For
Next idx
End If
End Function
'================================================================
Sub stop_kanshi()
'監視終了
stopflag = True
End Sub
'================================================================
Private Function f_actrl(ByVal s_obj As Variant, f_name As Variant, Optional ByVal c_cnt As Long = 0)
Dim sub_obj As Object
If c_cnt = 0 Then f_name = ""
If UCase(TypeName(s_obj)) = UCase("multipage") Then
f_name = f_name & "." & s_obj.Name
Set s_obj = s_obj.SelectedItem
End If
f_name = f_name & "." & s_obj.Name
With s_obj
Set sub_obj = Nothing
Set sub_obj = .ActiveControl
If sub_obj Is Nothing Then
Set f_actrl = Nothing
ElseIf UCase(TypeName(.ActiveControl)) = UCase("multipage") Then
Set f_actrl = f_actrl(.ActiveControl, f_name, c_cnt + 1)
ElseIf UCase(TypeName(.ActiveControl)) = UCase("frame") Then
Set f_actrl = f_actrl(.ActiveControl, f_name, c_cnt + 1)
Else
Set f_actrl = .ActiveControl
f_name = f_name & "." & .ActiveControl.Name
End If
End With
If c_cnt = 0 Then
f_name = Mid(f_name, 2)
End If
End Function
'================================================================
Private Sub Class_Initialize()
evc_cnt = 0
End Sub
'================================================================
Private Sub Class_Terminate()
Set f_ctrl = Nothing
Set n_ctrl = Nothing
Erase evc()
End Sub
標準モジュールに
'================================================================
Sub main()
UserForm1.Show
End Sub
として、mainを実行してみてください。
仕様は、パパちさんの投稿に合わせました。
Textboxを増やしても色の塗りつぶしに関してはコードの変更はいりません。
>方法を問わなければ、できるとは思います。
>（DLLとかCOMAddInを作成してTimer使用するなど）
これ作れば、シェアウエアで売れるかもねえ！！
どなたか作成して！！
|
|
ichinose
- 08/2/26(火) 8:24 -
