| 投稿日 | ： 2006/09/26(Tue) 11:26 |
| 投稿者 | ： YK |
| Ｅメール | ： |
| ＵＲＬ | ： |
| タイトル | ： Re: EXCEL2000のVBAでIMEHoldを実現する |
こんにちは。
ExitとEnterのイベントキャッチの方法です。
終了は必ずフォームから行って下さい。
VBEのリセットをかけるとお化けが出るときが有ります。
コードを見ていただければ説明は不要と思いますので省略します。
実はパクリです。
'クラスモジュール（Class1）
Private Declare Function SetTimer Lib "user32" ( _
ByVal Hwnd As Long, ByVal nIDEvent As Long _
, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Sub KillTimer Lib "user32" ( _
ByVal Hwnd As Long, ByVal nIDEvent As Long)
Event EnterControl(ByVal Ctrl As MSForms.Control)
Event ExitControl(ByVal Ctrl As MSForms.Control)
Private myForm As UserForm
Private myPreActiveControl As MSForms.Control
Private myTimerId As Long
Private Function GetActiveControl( _
ByVal ParentObject As Object) As MSForms.Control
Dim myContena As Object
Dim myActiveControl As MSForms.Control
On Error GoTo LstHdl
If TypeName(ParentObject) = "MultiPage" Then
Set myContena = ParentObject.SelectedItem
Else
Set myContena = ParentObject
End If
Set myActiveControl = myContena.ActiveControl
Select Case TypeName(myActiveControl)
Case "Frame", "MultiPage"
Set myActiveControl _
= GetActiveControl(myActiveControl)
End Select
Set GetActiveControl = myActiveControl
LstHdl:
Set myContena = Nothing
Set myActiveControl = Nothing
End Function
Public Sub CheckActiveControl()
Dim myActiveControl As MSForms.Control
On Error Resume Next
Set myActiveControl = GetActiveControl(myForm)
If myActiveControl Is Nothing Then Exit Sub
If myActiveControl Is myPreActiveControl Then GoTo LstHdl
RaiseEvent ExitControl(myPreActiveControl)
RaiseEvent EnterControl(myActiveControl)
Set myPreActiveControl = myActiveControl
LstHdl:
Set myActiveControl = Nothing
End Sub
Public Sub Init(ByVal myNewForm As UserForm)
Set myForm = myNewForm
Set myPreActiveControl = GetActiveControl(myForm)
RaiseEvent EnterControl(myPreActiveControl)
myTimerId = SetTimer(0&, 0&, 0&, AddressOf TimerProc)
End Sub
Private Sub Class_Terminate()
KillTimer 0&, myTimerId
Set myForm = Nothing
Set myPreActiveControl = Nothing
End Sub
'標準モジュール
Private Declare Sub KillTimer Lib "user32" ( _
ByVal Hwnd As Long, ByVal nIDEvent As Long)
Public Sub TimerProc(ByVal Hwnd As Long _
, ByVal uMsg As Long, ByVal idEvent As Long _
, ByVal dwTime As Long)
On Error Resume Next
If UserForms.Count = 0 Then
KillTimer 0&, idEvent
Exit Sub
End If
UserForm1.EventClass.CheckActiveControl
End Sub
'フォームモジュール（UserForm1）
Private WithEvents myClass As Class1
Private myCollection As Collection
Public Property Get EventClass() As Class1
Set EventClass = myClass
End Property
Private Function CheckControl( _
ByVal Ctrl As MSForms.Control) As Boolean
Dim myCtrl As MSForms.Control
For Each myCtrl In myCollection
If myCtrl Is Ctrl Then Exit For
Next
CheckControl = Not myCtrl Is Nothing
Set myCtrl = Nothing
End Function
'Enter時の処理（Ctrlはフォーカスを得たコントロールへの参照）
Private Sub myClass_EnterControl(ByVal Ctrl As MSForms.Control)
If Not CheckControl(Ctrl) Then Exit Sub
Ctrl.BackColor = vbBlack
End Sub
'Exit時の処理（Ctrlはフォーカスを得たコントロールへの参照）
Private Sub myClass_ExitControl(ByVal Ctrl As MSForms.Control)
If Not CheckControl(Ctrl) Then Exit Sub
Ctrl.BackColor = vbWhite
End Sub
Private Sub UserForm_Activate()
Static f As Boolean
Dim i As Long
If f Then Exit Sub
Set myCollection = New Collection
'イベントをハンドルしたいコントロールへの参照を
'コレクションに追加
With myCollection
For i = 1 To 10
.Add Me.Controls("TextBox" & i)
Next
End With
Set myClass = New Class1
myClass.Init Me
f = True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Intege
r)
Set myClass = Nothing
End Sub