Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


4842 / 13646 ツリー ←次へ | 前へ→

【54125】フォーカスのあたっているテキストボックスの色付け パパち 08/2/25(月) 19:18 質問[未読]
【54126】Re:フォーカスのあたっているテキストボッ... マクロマン 08/2/25(月) 19:38 発言[未読]
【54128】Re:フォーカスのあたっているテキストボッ... マクロマン 08/2/25(月) 19:53 発言[未読]
【54129】Re:フォーカスのあたっているテキストボッ... ハチ 08/2/25(月) 20:38 発言[未読]
【54131】Re:フォーカスのあたっているテキストボッ... neptune 08/2/25(月) 22:33 発言[未読]
【54136】Re:フォーカスのあたっているテキストボッ... ichinose 08/2/26(火) 8:24 発言[未読]
【54138】Re:フォーカスのあたっているテキストボッ... パパち 08/2/26(火) 9:34 お礼[未読]

【54125】フォーカスのあたっているテキストボック...
質問  パパち  - 08/2/25(月) 19:18 -

引用なし
パスワード
   ユーザフォーム上にテキストボックス3つとコマンドボタン
を配置し、コマンドボタンをおすとテキストボックスに入力
した値をセルに記入するマクロを作っています。
その中で、どのテキストボックスにフォーカスがあるか
カーソルでは見にくいので、フォーカスのあたっている
テキストボックスに色付けをしようと考えています。
で、下記のとおり記述をしましたが、このやり方だと
テキストボックスが増えるたびにコードを追加しないといけく
なるのですが、簡単な記述はあるでしょうか。
ご教示おねがいします。


Private Sub CommandButton1_Click()
  ActiveSheet.Cells(1, 1) = TextBox1.Value
  ActiveSheet.Cells(1, 2) = TextBox2.Value
  ActiveSheet.Cells(1, 3) = TextBox3.Value
  Unload Me
End Sub

Private Sub TextBox1_Enter()
  TextBox1.BackColor = &H80FFFF
End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  TextBox2.BackColor = &HFFFFFF
End Sub

Private Sub TextBox2_Enter()
  TextBox2.BackColor = &H80FFFF
End Sub

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  TextBox2.BackColor = &HFFFFFF
End Sub

Private Sub TextBox3_Enter()
  TextBox3.BackColor = &H80FFFF
End Sub

Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  TextBox3.BackColor = &HFFFFFF
End Sub

【54126】Re:フォーカスのあたっているテキストボ...
発言  マクロマン  - 08/2/25(月) 19:38 -

引用なし
パスワード
   あまり詳しいことは分からないのですが、クラス
を使うことになると思います。

【54128】Re:フォーカスのあたっているテキストボ...
発言  マクロマン  - 08/2/25(月) 19:53 -

引用なし
パスワード
   参考HPです。

http://www.h3.dion.ne.jp/~sakatsu/Breakthrough_P-Ctrl_Arrays.htm

【54129】Re:フォーカスのあたっているテキストボ...
発言  ハチ  - 08/2/25(月) 20:38 -

引用なし
パスワード
   ▼パパち さん:
クラスモジュールを使わずに無理やりやるなら、こんな感じでもできます。
それでもEnterイベントには追記していく必要があります。

Option Explicit

Private obj_Text As Control

Private Sub Chk_obj_Text()
  If Not obj_Text Is Nothing Then
    obj_Text.BackColor = &HFFFFFF
    Set obj_Text = Nothing
  End If
  If TypeName(ActiveControl) = "TextBox" Then
    Set obj_Text = ActiveControl
    obj_Text.BackColor = &H80FFFF
  End If
End Sub

Private Sub CommandButton1_Click()
  Call Chk_obj_Text
End Sub

Private Sub TextBox1_Enter()
  Call Chk_obj_Text
End Sub

Private Sub TextBox2_Enter()
  Call Chk_obj_Text
End Sub

Private Sub TextBox3_Enter()
  Call Chk_obj_Text
End Sub

【54131】Re:フォーカスのあたっているテキストボ...
発言  neptune  - 08/2/25(月) 22:33 -

引用なし
パスワード
   ▼パパち さん:
こんにちは

Classを使用する方法を紹介されていますが、基本的に
ClassではUserFormのTextBoxのEnter、Exitイベントは取得できません。

パパち さんの現在のやり方か、ハチさんの方法をお勧めします。
個人的にはハチさんの方法がお勧め。

※Classでも、CPU全開の方法(Doevents回しっ放しでフォーカスのある所を
 監視する)を取ればできるんでしょうがとてもお勧めできません。
※方法を問わなければ、できるとは思います。
(DLLとかCOMAddInを作成してTimer使用するなど)

【54136】Re:フォーカスのあたっているテキストボ...
発言  ichinose  - 08/2/26(火) 8:24 -

引用なし
パスワード
   おはようございます。

>※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使用するなど)
これ作れば、シェアウエアで売れるかもねえ!!
どなたか作成して!!

【54138】Re:フォーカスのあたっているテキストボ...
お礼  パパち  - 08/2/26(火) 9:34 -

引用なし
パスワード
   マクロマンさん、ハチさん、neptuneさん、ichinoseさん

ご教示ありがとうございます。
neptuneさん、ichinoseさんがおっしゃるようにクラスを
つかうよりは、ハチさんのやり方のほうがよさそうですね。
(私も今後は業務で使うファイルに応用するつもりなので)
ハチさんのコードを参考に勉強しながらやっていきたいと
おもいます。
本当にありがとうございました。

4842 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free