ロゴ（青） 擬似からの脱却 ロゴ（緑）

  【 擬似からの脱却 】  [ Breakthrough in the Pseudo-Control Arrays ]

[ clsBpca の 軌跡 ] [ 前頁 , 次頁 , §１ , §２ , §３ , §４ , §５ , §６ , §７ , §８ , §９ , §１０ , §１１ , §１２ ]
[ 汎用クラス , トグルラベル クラス , Focus クラス , クラス アドイン , カレンダークラス ] [ 質問はメールへ ]

  ====================================================================
  §１１  その他のサンプルコード
  ====================================================================

2005/3/11 解説文・クラスソース・サンプルブック において、オブジェクト定義時での[New]指定 を止めて、
                Initialize 時にインスタンス生成（Set ステートメント）するように修正しました。
2014/8/11  clsBpca (Ver 2.0) のリリースに伴い、Enter/Exit イベントのサンプルを追加しました。
2016/11/3  動的作成 コントロール への適用例のサンプルを追加しました。
2020/9/1   ワークシート上の コントロールに対する利用例を追加しました。


（前節より‥‥‥）
      最後に、この「擬似からの脱却」手法の汎用クラスモジュール【 clsBpca 】を
      利用したサンプルの 幾つかを紹介します。

下記のサンプルは、汎用クラスのブックに収録されているコードです。
      (1) Exit を使って数字以外なら警告表示 および
           Enter/Exit を使って ActiveControl 表示    2014/8/11 追加
            （Enter , Exit イベントは clsBpca (Ver 2.0) より利用できます）
      (2) Change を使って選択したOptionButton を強調表示
      (3) Change を使って数字以外なら警告表示
      (4) KeyDown を使って入力終了時に英数字以外なら警告表示
      (5) 『電    卓』    2006/9/20 一部修正
      (6) MouseMove 応用例 『カラーパレット』
      (7) MouseMove 応用例 『カレンダーフォーム』
      (8) MouseMove 応用例 『日本地図フォーム』
      (9) 排他あり トグルボタン    2011/11/3 追加
      (10) 動的作成コントロールへの適用例    2016/11/3 追加
      (11) ワークシート上のコントロールへの適用例    2020/9/1 追加  

（お願い）  以下に掲載の コードを他媒体(掲示板、ブログ etc ） に丸々貼り付ける事はご遠慮ください。
              各コード箇所にはリンクが用意してありますので、そのＵＲＬ を紹介するようにして下さい。


[ この場所へのリンク ]

Video capture ( Bpca_EnterExitEvent.mp4  0.6MB )

  [ Exit ] を使って数字以外なら警告表示(TextBox ) および
  [ Enter , Exit ] を使って ActiveControl 表示

  Enter/Exit は clsBpca (Ver 2.0) から利用可能です。
  clsBpca では、Enter/Exit イベントが OnEnter/OnExit
  の名前で定義されています。

  クラスモジュールで Enter/Exit イベントを受け取る
  仕組みは §１２ を参照
  Private WithEvents NumBox As clsBpca

  Private Sub UserForm_Initialize()
      Set NumBox = New clsBpca    ' インスタンスの生成
      With NumBox
          .Add txtNum1
          .Add txtNum2
          .Add txtNum3
          .Add txtNum4
          .Rgst  BPCA_EnterExit
      End With
  End Sub

  Private Sub UserForm_Terminate()
      NumBox.Clear
      Set NumBox = Nothing
  End Sub

  Private Sub NumBox_OnEnter(ByVal Index As Integer)
      NumBox.ItmTxt(Index).BackColor = &HFFFFE0      'LightCyan
  End Sub

  Private Sub NumBox_OnExit(ByVal Index As Integer, _
                            ByVal Cancel As MSForms.ReturnBoolean)
      If (NumBox.ItmTxt(Index).Value = "") Then
          'Empty is OK
      ElseIf IsNumeric(NumBox.ItmTxt(Index).Value) Then
          'Numeric is OK
      Else
          'Numeric Error
          NumBox.ItmTxt(Index).BackColor = &HCCCCFF      'Light Red
          Beep
          Cancel = True
          Exit Sub
      End If

      NumBox.ItmTxt(Index).BackColor = vbWindowBackground
  End Sub
 


[ この場所へのリンク ]

  [Change]を使って選択したボタンの
  カラーを強調表示（OptionButton )
  Private WithEvents OptBtn As clsBpca

  Private Sub UserForm_Initialize()
      Set OptBtn = New clsBpca    ' インスタンスの生成
      With OptBtn
          .Add OptionButton1
          .Add OptionButton2
          .Add OptionButton3
          .Add OptionButton4
          .Add OptionButton5
          .Rgst BPCA_Change
      End With
  End Sub

  Private Sub UserForm_Terminate()
      OptBtn.Clear
      Set OptBtn = Nothing
  End Sub

  Private Sub OptBtn_Change(ByVal Index As Integer)
      With OptBtn.ItmOpt(Index)
          If (.Value = True) Then
              .BackColor = &HCCCCFF    '薄赤
          Else
              .BackColor = Me.BackColor    'Userformと同色
          End If
      End With
  End Sub

  Private Sub cmdOptReset_Click()    '←普通のコントロールのイベント
  Dim i As Integer
      For i = 1 To 5
          With OptBtn.ItmOpt(i)
              If (.Value = True) Then
                  .Value = False    '色変更は↑の[Change]に任せる
              End If
          End With
      Next i
  End Sub
 


[ この場所へのリンク ]

  [Change] を使って数字以外なら警告表示(TextBox )
  Private WithEvents NumBox As clsBpca

  Private Sub UserForm_Initialize()
      Set NumBox = New clsBpca    ' インスタンスの生成
      With NumBox
          .Add txtNum1
          .Add txtNum2
          .Add txtNum3
          .Rgst BPCA_Change
      End With
  End Sub

  Private Sub UserForm_Terminate()
      NumBox.Clear
      Set NumBox = Nothing
  End Sub

  Private Sub NumBox_Change(ByVal Index As Integer)
      With NumBox.ItmTxt(Index)
          If IsNumeric(.Value) Then
              .BackColor = vbWindowBackground
          Else
              .BackColor = &HCCCCFF    '薄赤
          End If
      End With
  End Sub
 


[ この場所へのリンク ]

  [KeyDown] を使って入力終了時に英数字以外なら
  警告表示(TextBox )

  (注) マウスで抜けた場合は効きません。
  Private WithEvents AlfaNumBox As clsBpca

  Private Sub UserForm_Initialize()
      Set AlfaNumBox = New clsBpca    ' インスタンスの生成
      With AlfaNumBox
          .Add txtAN1
          .Add txtAN2
          .Add txtAN3
          .Rgst BPCA_KeyDown
      End With
  End Sub

  Private Sub UserForm_Terminate()
      AlfaNumBox.Clear
      Set AlfaNumBox = Nothing
  End Sub

  '※ マウスで抜けたら効きません
  Private Sub AlfaNumBox_KeyDown _
    (ByVal Index As Integer, _
      ByVal KeyCode As MSForms.ReturnInteger, _
      ByVal Shift As Integer)
  Dim i As Integer
  Dim blnERR As Boolean
      With AlfaNumBox.ItmTxt(Index)
          Select Case KeyCode
              Case vbKeyTab, vbKeyReturn, vbKeyUp, vbKeyDown
                  '入力終了キー
                  blnERR = False
                  For i = 1 To Len(.Value)
                      Select Case Mid(.Value, i, 1)
                          Case "0" To "9"
                          Case "A" To "Z"
                          Case "a" To "z"
                          Case Else
                              blnERR = True
                      End Select
                  Next i
                  If (blnERR = False) Then
                      .BackColor = vbWindowBackground
                  Else
                      .BackColor = &HCCCCFF    '薄赤
                  End If
              Case Else
                  '入力中
          End Select
      End With
  End Sub
 


[ この場所へのリンク ]

  『 電 卓 』
  2006/09/20    クリア後に '0' を連続した場合､１個の '0' に抑えるよう修正。
  デモブックには反映されていません。下記修正を確認して手直して下さい。
  Private WithEvents CalcNum As clsBpca
  Private WithEvents CalcOpr As clsBpca
  Private intOperate As Integer  ' 電卓 演算子

  Private Sub UserForm_Initialize()
  Dim i As Integer
      txtCalcResult.Value = ""
      txtCalcBuff.Value = ""
      intOperate = 0

      Set CalcNum = New clsBpca    ' インスタンスの生成
      With CalcNum
          For i = 1 To 9
              .Add Me.Controls("cmdCalc" & i)
          Next i
          .Add cmdCalc0        '[10]
          .Add cmdCalcSign    '[11]
          .Add cmdCalcPoint    '[12]
          .Rgst BPCA_Click
      End With

      Set CalcOpr = New clsBpca    ' インスタンスの生成
      With CalcOpr
          .Add cmdCalcClear    '[1]
          .Add cmdCalcMulti    '[2]
          .Add cmdCalcDivide  '[3]
          .Add cmdCalcPlus      '[4]
          .Add cmdCalcMinus   '[5]
          .Add cmdCalcEQ       '[6]
          .Rgst BPCA_Click
      End With
  End Sub

  Private Sub UserForm_Terminate()
      CalcNum.Clear
      CalcOpr.Clear
      Set CalcNum = Nothing
      Set CalcOpr = Nothing
  End Sub

  Private Sub CalcNum_Click(ByVal Index As Integer)
  Dim strWK As String
      If (intOperate = 6) And (Index <> 11) Then
          strWK = ""
          intOperate = 0
      Else
          strWK = txtCalcResult.Value
      End If

      Select Case Index
          Case 1 To 9
              ' strWK = strWK & Index    '06/09/20修正
              Select Case strWK
                  Case "0"
                      strWK = Index    '先頭0は省く
                  Case "-0"
                      strWK = "-" & Index    '先頭0は省く
                  Case Else
                      strWK = strWK & Index
              End Select
          Case 10
              ' strWK = strWK & "0"      '06/09/20修正
              Select Case strWK
                  Case "0", "-0", "-"
                      ' 0を並べても「0は0」なので､そのまま
                  Case Else
                      strWK = strWK & "0"
              End Select
          Case 11  '符号
              If (Left(strWK, 1) = "-") Then
                  strWK = Mid(strWK, 2)
              Else
                  strWK = "-" & strWK
              End If
          Case 12  '小数点
              If (InStr(strWK, ".") = 0) Then
                  strWK = strWK & "."
              End If
      End Select
      txtCalcResult.Value = strWK
  End Sub

  Private Sub CalcOpr_Click(ByVal Index As Integer)
  Dim i As Integer
      Select Case Index
          '[ＡＣ]
          Case 1
              txtCalcResult.Value = ""
              txtCalcBuff.Value = ""
              intOperate = 0
              For i = 2 To 5
                  CalcOpr.ItmCmd(i).BackColor = vbButtonFace
              Next i
          '[×][÷][＋][−]
          Case 2 To 5
              If (intOperate >= 2) And (intOperate <= 5) Then
                  Call Calc_Sub
              End If
              intOperate = Index
              txtCalcBuff.Value = txtCalcResult.Value
              txtCalcResult.Value = ""
              For i = 2 To 5
                  With CalcOpr.ItmCmd(i)
                      If (i = Index) Then
                          .BackColor = &HC0FFFF
                      Else
                          .BackColor = vbButtonFace
                      End If
                  End With
              Next i
          '[＝]
          Case 6
              Call Calc_Sub
              intOperate = 6
              For i = 2 To 5
                  CalcOpr.ItmCmd(i).BackColor = vbButtonFace
              Next i
      End Select
  End Sub

  Private Sub Calc_Sub()
  Dim dblNum1 As Double
  Dim dblNum2 As Double
      dblNum1 = Val(txtCalcBuff.Value)
      dblNum2 = Val(txtCalcResult.Value)
      Select Case intOperate
          Case 2
              txtCalcResult.Value = CStr(dblNum1 * dblNum2)
          Case 3
              If ( dblNum2 <> 0 ) Then
                  txtCalcResult.Value = CStr(dblNum1 / dblNum2)
              Else
                  txtCalcResult.Value = "0"
              End If
          Case 4
              txtCalcResult.Value = CStr(dblNum1 + dblNum2)
          Case 5
              txtCalcResult.Value = CStr(dblNum1 - dblNum2)
      End Select
      txtCalcBuff.Value = ""
  End Sub
 


[ この場所へのリンク ]

  [MouseMove] 応用例 『カラーパレット』
  lblPalette1〜lblPalette56 というラベルが
  ColorIndex の並びに合わせて配置され
  ています（下図参照）。
  カレンダークラスアドインに「パレットクラス」
  が付属しています。
  Private WithEvents Palette As clsBpca

  Private Sub UserForm_Initialize()
  Dim i As Integer
      lblPaletteRGB.Caption = ""
      Set Palette = New clsBpca    ' インスタンスの生成
      With Palette
          For i = 1 To 56
              .Add Me.Controls("lblPalette" & i)
          Next i
          .Add lblPaletteFrame    '(57)
          .Rgst BPCA_MouseMove + BPCA_Click
      End With
      For i = 1 To 56
          With Palette.ItmLbl(i)
              .BackColor = ThisWorkbook.Colors(i)
              .ControlTipText = "(" & Format(i, "00") & ") x" & _
                                Right("000000" & Hex(ThisWorkbook.Colors(i)), 6)
          End With
      Next i
  End Sub

  Private Sub UserForm_Terminate()
      Palette.Clear
      Set Palette = Nothing
  End Sub

  Private Sub Palette_Click(ByVal Index As Integer)
      If (Index <= 56) Then
          lblPaletteRGB.BackColor = Palette.ItmLbl(Index).BackColor
      End If
  End Sub

  Private Sub Palette_MouseMove _
          (ByVal Index As Integer, ByVal Button As Integer, _
            ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim i As Integer
      Select Case Index
          Case 1 To 56
              'マウスがパレット上の時、当該パレットのみ凸形状
              For i = 1 To 56
                  With Palette.ItmLbl(i)
                      If (i = Index) Then
                          If (.SpecialEffect = fmSpecialEffectEtched) Then
                              .SpecialEffect = fmSpecialEffectRaised
                          End If
                      Else
                          If (.SpecialEffect = fmSpecialEffectRaised) Then
                              .SpecialEffect = fmSpecialEffectEtched
                          End If
                      End If
                  End With
              Next i
          Case Else
              'マウスがパレットを外れたら全てフラットに戻す
              '[ lblPaletteFrame(57) ]
              For i = 1 To 56
                  With Palette.ItmLbl(i)
                      If (.SpecialEffect = fmSpecialEffectRaised) Then
                          .SpecialEffect = fmSpecialEffectEtched
                      End If
                  End With
              Next i
      End Select
  End Sub
 


[ この場所へのリンク ]

Video capture ( Bpca_CalendarForm.mp4   0.4MB )
 
  カレンダーフォームのサンプル
  マウス位置の日付が水色で強調表示されて、
  クリックすると MsgBox に日付を表示します。
      spnMonth : [年月]切り換え
      lblMonth  : [年月]表示
      lblDay1 〜 37 : 日付ラベル

  七曜暦レイアウトの作成方法はこちら参照

「カレンダークラスアドイン」を使えば、もっと簡単にカレンダーフォームを作れます。

下記コードにおいて茶色で示されている『祝日表示』コードの部分は、[汎用クラス]ブック
には含まれていませんので、このページからコピーして下さい（祝日の日付が[赤]になり、
コントロールチップテキストに祝日名がセットされます）。尚、その際には
        『祝日判定ロジック（ ktHolidayName 関数）』
が必要になります。標準モジュールを用意し、そこに祝日判定ロジック（ＶＢＡ）をコピーし
て下さい。（2004/7/17 追記）

※ 2005/5/20 祝日判定ロジックを 「昭和の日」 対応で 修正してありますので差し替えてください。
※ 2014/5/29 祝日判定ロジックを 「山の日」 対応で 修正してありますので差し替えてください。
※ 2018/2/15 祝日判定ロジックを 「天皇誕生日の変更」 対応で 修正してありますので差し替えてください。
※ 2018/6/21 祝日判定ロジックを 「東京五輪 祝日移動(2020年)/体育の日の改名」 対応で 修正してありますので差し替えてください。
※ 2018/12/8 祝日判定ロジックを 「即位 関連休日」 対応で 修正してありますので差し替えてください。
※ 2020/11/28 祝日判定ロジックを 「東京五輪 祝日移動(2021年)」 対応で 修正してありますので差し替えてください。
  Private WithEvents CalBtn As clsBpca
  Private dtmBaseDate As Date
  Private dtmFirstDate As Date
  Private dtmLastDate As Date

  Private Sub UserForm_Initialize()
  Dim i As Integer
      Set CalBtn = New clsBpca    ' インスタンスの生成
      With CalBtn
          For i = 1 To 37
              .Add Me.Controls("lblDay" & i)
          Next i
          .Rgst BPCA_Click + BPCA_MouseMove
      End With
      dtmFirstDate = DateSerial(Year(Date), Month(Date), 1)
      Call CalendarMake
  End Sub

  Private Sub UserForm_MouseMove _
        (ByVal Button As Integer, ByVal Shift As Integer, _
          ByVal X As Single, ByVal Y As Single)
     '[0]を渡す事で全ての強調表示をオフになる
      Call CalMousePoint(0)
  End Sub

  Private Sub UserForm_Terminate()
      CalBtn.Clear
      Set CalBtn = Nothing
  End Sub

  '----- 日付ボタンの処理 -----
  Private Sub CalBtn_Click(ByVal Index As Integer)
      MsgBox "Click Date = " & _
            Format(dtmBaseDate + Index - 1, "yyyy/m/d")
  End Sub

  Private Sub CalBtn_MouseMove _
          (ByVal Index As Integer, ByVal Button As Integer, _
            ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
      'マウス位置のボタンを強調表示
      Call CalMousePoint(Index)
  End Sub

  '----- 年月のシフト --------
  Private Sub spnMonth_SpinDown()
      dtmFirstDate = DateSerial(Year(dtmFirstDate), Month(dtmFirstDate) - 1, 1)
      Call CalendarMake
  End Sub

  Private Sub spnMonth_SpinUp()
      dtmFirstDate = DateSerial(Year(dtmFirstDate), Month(dtmFirstDate) + 1, 1)
      Call CalendarMake
  End Sub

  '----- カレンダーレイアウトの作成 -----
  Private Sub CalendarMake()
  Dim dtmWK As Date
  Dim i As Integer
      dtmLastDate = DateSerial(Year(dtmFirstDate), Month(dtmFirstDate) + 1, 0)
      dtmBaseDate = dtmFirstDate - Weekday(dtmFirstDate) + 1

      lblMonth.Caption = Format(dtmFirstDate, "yyyy年m月")
      For i = 1 To 37
          dtmWK = dtmBaseDate + i - 1
          With CalBtn.ItmLbl(i)
              If (dtmWK >= dtmFirstDate) And (dtmWK <= dtmLastDate) Then
                  .Caption = Day(dtmWK)
                  .Visible = True
                  If (dtmWK = Date) Then
                      .Font.Underline = True    '本日表示
                  Else
                      .Font.Underline = False
                  End If
                 '====== ↓祝日表示 =======================
                  .ControlTipText = ktHolidayName(dtmWK)
                  If (.ControlTipText <> "") Then
                      '祝日
                      .ForeColor = vbRed
                  Else
                      Select Case Weekday(dtmWK)
                          Case vbSunday
                              .ForeColor = vbRed
                          Case vbSaturday
                              .ForeColor = vbBlue
                          Case Else
                              .ForeColor = vbBlack
                      End Select
                  End If
                  '====== ↑祝日表示 ======================
              Else
                  .Visible = False
              End If
          End With
      Next i
  End Sub

  '---- マウスの当っている日付を強調表示 ----
  Private Sub CalMousePoint(ByVal Index As Integer)
  Dim i As Integer
      For i = 1 To 37
          With CalBtn.ItmLbl(i)
              If (i = Index) Then
                  If (.BackColor = Me.BackColor) Then
                      .BackColor = &HFFFFC0    '薄水色
                 End If
              Else
                  If (.BackColor <> Me.BackColor) Then
                      .BackColor = Me.BackColor
                  End If
              End If
          End With
      Next i
  End Sub
 

  配布ファイルに同梱してある [ frmCalendarTool ] を使えば汎用のカレンダー
  ツールが利用できるようになります。

  配布ファイルの [ Bpca_Class_V40.zip > Export_V40 > frmCalendarTool.frm ] をインポート
  して下さい。

  日付ボタン or 閉じるボタンをクリックした場合、frmCalendarTool は Hide でフォームを閉じ
  ます（上記の frmBpca3 とは異なります）ので、呼び元のマクロで結果（日付 or -1）を受け
  取れます。下記の CalendarForm 関数を用意すれば、ポップアップカレンダーによる日付
  入力が、どこででも可能になります。
 
  === frmCalendarTool module ===
   'Serial_Number(Date clicked) or [-1](Cancel)
   Public ReturnValue As Date
   Private WithEvents CalBtn As clsBpca
       :
       :
 
   Private Sub UserForm_QueryClose _
             (Cancel As Integer, CloseMode As Integer)
     If (CloseMode = vbFormControlMenu) Then
       Cancel = True
       ReturnValue = -1    'Cancel
       Me.Hide
     End If
   End Sub
 
   Private Sub CalBtn_Click(ByVal Index As Integer)
     ReturnValue = dtmBaseDate + Index - 1
     Me.Hide
   End Sub
 
 
 === Standard module ===
   Public Function CalendarForm() As Date
     frmCalendarTool.Show
     CalendarForm = frmCalendarTool.ReturnValue
     Unload frmCalendarTool
   End Function

 === Any UserForm ===
   Private Sub TextBox1_DblClick _
         (ByVal Cancel As MSForms.ReturnBoolean)
   Dim DateWk As Date
     DateWk = CalendarForm
     If (DateWk = -1) Then
       'Cancel
     Else
       TextBox1.Value = Format(DateWk, "yyyy/m/d")
     End If
     Cancel = True
   End Sub
 
   Private Sub TextBox2_DblClick _
         (ByVal Cancel As MSForms.ReturnBoolean)
   Dim DateWk As Date
     DateWk = CalendarForm
     If (DateWk = -1) Then
       'Cancel
     Else
       TextBox2.Value = Format(DateWk, "yyyy/m/d")
     End If
     Cancel = True
   End Sub


[ この場所へのリンク ]

Video capture ( Bpca_JapanMapForm.mp4   0.9MB )


都道府県 選択ツール『日本地図フォーム』  （2005/4/4 追記）
  カレンダーやカラーパレットと同様に MouseMove/Click イベントを使った応用例です。
尚、このサンプルは汎用クラスブックには収録されていません。
クラスアドインおよびkt電話郵便アドインで公開（公開インターフェースはサブルーチン）。

  都道府県を入力させるケースで、コードや名称を手入力/コンボボックス等で行なう代わ
りに、地図フォームからマウスで選択させる事ができます。

  サブルーチン[ ktJapanMap ] を Call するだけで、地図フォームがポップアップし、マウ
スに合わせてマウス位置の都道府県が強調表示されますので、そのままクリックすれば、
その選択した都道府県のコード及び名称が引数で受け取れます。

  背景色は任意に変更できます。その他、サブルーチン構文/利用方法は、クラスアドイン
の[ ReadMe.txt ]を参照して下さい。
  Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  Dim int都道府県 As Integer
  Dim str都道府県名 As String
      Call ktJapanMap (int都道府県, str都道府県名, &HFFFFF0)
      If (int都道府県 <> 0) Then
          TextBox1.Value = str都道府県名
      End If
      Cancel = True    'DblClick動作解除
  End Sub
 
    （注） クラスアドインでは ktJapanMap、kt電話郵便アドインでは ktJapanMap2 の関数名
          で収録しています（両アドインを利用した場合に関数名の重複を避ける為）。


[ この場所へのリンク ]

トグルボタンには、オプションボタンのような排他機能はありませんが、clsBpcaCmd の応用で、
『排他処理』機能を付加したトグルボタンクラスを作成できます（排他処理に伴う[ON→OFF]変更
コントロールでは[Click]イベントは発生しないように作ってあります）。

チェックボックスコントロールも、下記と同様の処理で排他機能を持たせることが可能です。
※ 下記サンプルマクロには「汎用クラス(clsBpca)」は必要ありません。
 '=== UserForm ===
 Private WithEvents clsTgl1 As clsBpcaTgl

 Private Sub UserForm_Initialize()
 Dim i As Integer
   Set clsTgl1 = New clsBpcaTgl
   With clsTgl1
     For i = 1 To 4
       .Add Me.Controls("ToggleButton" & i)
     Next i
     .Rgst True      '[True]指定で[排他あり]
   End With
 End Sub
 
 Private Sub UserForm_Terminate()
   clsTgl1.Clear ' クラスの終了処理
   Set clsTgl1 = Nothing
 End Sub
 
 Private Sub clsTgl1_Change(ByVal Index As Integer)
 'User/Macro操作によるCtrl および
 'その変更に伴う排他処理による[ON⇒OFF]変更Ctrl で[Change]が発生する
   With clsTgl1.Item(Index)
     If (.Value = True) Then
       .BackColor = vbRed
     Else
       .BackColor = vbButtonFace
     End If
   End With
 End Sub
 
 Private Sub clsTgl1_Click(ByVal Index As Integer)
 'User/Macro操作によるCtrlのみ[Click]が発生する
 '（排他処理による[ON⇒OFF]変更Ctrl では[Click]は発生しないクラス仕様）
   With clsTgl1.Item(Index)
     If (.Value = True) Then
       MsgBox "[Click] (" & Index & ") False⇒True"
     Else
       MsgBox "[Click] (" & Index & ") True⇒False"
     End If
   End With
 End Sub



 '=== clsBpcaTgl ===
 
 '------[ 発生イベント定義(利用側へ上げる) ]--------------
 Public Event Change(ByVal Index As Integer)
 Public Event Click(ByVal Index As Integer)
 
 '------[ コントロール配列定義 ]--------------------------
 Private clsCtrlCh() As clsBpcaTglCh
 Private colCtrl As Collection
 
 Private blnRgst As Boolean                 'Rgst 済(True)/未(False)
 Private blnExclusive As Boolean          '排他あり(True)/排他なし(False)
 Private blnExclusiveLoop As Boolean    '排他で他Ctrlの変更処理中(True)
 
 Private Sub Class_Initialize()
   Set colCtrl = New Collection   ' インスタンスの生成
 End Sub

 Private Sub Class_Terminate()
   If (blnRgst = True) Or (Not (colCtrl Is Nothing)) Then
     '呼び元(UserForm)での「後始末： Clear メソッド実行」忘れへの対策
     Me.Clear
   End If
 End Sub
 
 '---( Add メソッド )------------------------------------
 '配列化するコントロールをコレクションに追加
 Public Sub Add(ByVal NewCtrl As MSForms.ToggleButton)
   colCtrl.Add NewCtrl
 End Sub
 
 '---( Rgst メソッド)------------------------------------
 'コレクションに載せたコントロールをクラス登録して配列化
 Public Sub Rgst(ByVal argExclusive As Boolean)
 Dim i As Integer
   If (blnRgst = True) Then
     '実行済み
   ElseIf (colCtrl.Count = 0) Then
     blnRgst = False
   Else
     ReDim clsCtrlCh(1 To colCtrl.Count)
     For i = 1 To colCtrl.Count
       Set clsCtrlCh(i) = New clsBpcaTglCh
       With clsCtrlCh(i)
         .Item = colCtrl(i)
         .Index = i
         .Parent = Me
       End With
     Next i
     blnRgst = True
     blnExclusive = argExclusive
   End If
 End Sub
 
 '---( Clear メソッド Classの解放/初期化 )--------------------
 Public Sub Clear()
 Dim i As Integer
   If (blnRgst = True) Then
     For i = 1 To colCtrl.Count
       clsCtrlCh(i).Clear
     Next i
   End If
   Set colCtrl = Nothing
   Erase clsCtrlCh
   blnRgst = False
 End Sub
 
 '---( Count プロパティ)--------------------------------------
 '登録されているコントロール数を返す
 Public Property Get Count() As Integer
   Count = colCtrl.Count
 End Property
 
 '---( Item プロパティ)---------------------------------------
 'コントロール配列から、個々のコントロールオブジェクトを返す
 Public Property Get Item(ByVal Index As Integer) As MSForms.ToggleButton
   If (blnRgst = True) And (Index <= colCtrl.Count) Then
     Set Item = colCtrl(Index)
   Else
     Set Item = Nothing
   End If
 End Property
 
 '===========================================================
 '===== clsBpcaTglCh から呼ばれるイベント励起メソッド =========
 '===========================================================
 Public Sub RaiseChange(ByVal Index As Integer)
 Dim j As Integer
   RaiseEvent Change(Index)
 
   If (blnExclusiveLoop = False) Then
     If (blnExclusive = True) Then
       If (colCtrl(Index).Value = True) Then
         '[False⇒True] 他の[ON]Ctrlを[OFF]へ変更
         blnExclusiveLoop = True
         For j = 1 To colCtrl.Count
           If (j <> Index) Then
             If (colCtrl(j).Value = True) Then
               colCtrl(j).Value = False
             End If
           End If
         Next j
         blnExclusiveLoop = False
       Else
         '[True⇒False] 何もしない
       End If
     End If
     '全ての[Change]発行後に、User/Macro操作によるCtrlのみ[Click]を発行
     RaiseEvent Click(Index)
 
   Else
     '排他による[ON]Ctrlの変更中
   End If
 End Sub


'=== clsBpcaTglCh ===
 
 '------[ イベントを取得する為のコントロール定義 ]-------------------
 Private WithEvents MyCtrl As MSForms.ToggleButton
 Private MyIndex As Integer
 Private MyParent As clsBpcaTgl
 Private blnParent As Boolean
 
 '---( Clear メソッド)----------------------------------------------
 Public Sub Clear()
   Set MyCtrl = Nothing
   Set MyParent = Nothing
   blnParent = False
   MyIndex = 0
 End Sub
 
 '---( Item プロパティ)------------------------------------------------
 Public Property Let Item(NewCtrl As MSForms.ToggleButton)
   Set MyCtrl = NewCtrl
 End Property
 
 '---( Index プロパティ)------------------------------------------------
 Public Property Let Index(NewIndex As Integer)
   MyIndex = NewIndex
 End Property
 
 '---( Parent プロパティ)------------------------------------------------
 Public Property Let Parent(NewParent As clsBpcaTgl)
   blnParent = True
   Set MyParent = NewParent
 End Property
 
 '===================================================================
 '===== 登録したコントロールのイベントを取得する ======================
 '===================================================================
 'コントロールのイベントを受けたら、そのまま、呼び元の親クラスへ、更にイベントを上げる
 Private Sub MyCtrl_Change()
   If (blnParent = True) Then
     MyParent.RaiseChange MyIndex
   End If
 End Sub
 
 


[ この場所へのリンク ]
動的作成コントロールへの適用例    2016/11/3 追加

２〜５行目のコントロールセットを動的に作成します（１行目はデザイン時に作成済）。
追加したコントロールを削除して初期状態に戻す事もできます。
[ Bpca_DynamicCreate.xls ]

 'colAddCtrlにはオブジェクトではなくコントロール名で保存します（Removeの為）
 Private colAddCtrl As Collection

 Private WithEvents AddChkEnable As clsBpca
 Private WithEvents AddTxtName As clsBpca
 Private WithEvents AddTxtAddr As clsBpca

 '---------------------------------------------------------
 Private Sub Bpca_Clear()
    AddChkEnable.Clear
    AddTxtName.Clear
    AddTxtAddr.Clear

    Set AddChkEnable = Nothing
    Set AddTxtName = Nothing
    Set AddTxtAddr = Nothing
 End Sub

 '---------------------------------------------------------
 Private Sub Bpca_Registration()
 Dim vntArray As Variant
 Dim j As Integer

    Set AddChkEnable = New clsBpca
    Set AddTxtName = New clsBpca
    Set AddTxtAddr = New clsBpca

    For j = 1 To colAddCtrl.Count
        vntArray = colAddCtrl(j)
        AddChkEnable.Add Me.Controls(vntArray(1))  'chkEnable
        AddTxtName.Add Me.Controls(vntArray(2))    'txtName
        AddTxtAddr.Add Me.Controls(vntArray(3))    'txtAddr
    Next j

    AddChkEnable.Rgst BPCA_Change + BPCA_EnterExit
    AddTxtName.Rgst BPCA_Change + BPCA_EnterExit
    AddTxtAddr.Rgst BPCA_Change + BPCA_EnterExit
 End Sub

 '---------------------------------------------------------
 Private Sub DisplayListBox(ByVal Arg As String)
    With ListBox1
        .AddItem Arg
        .ListIndex = .ListCount - 1
    End With
 End Sub
 '---------------------------------------------------------
 Private Sub UserForm_Initialize()
    'デザイン時に用意されている１行目(lblNo1 & chkEnable1 & txtName1 & txtAddr1)用
    Set colAddCtrl = New Collection
    colAddCtrl.Add Array("lblNo1", "chkEnable1", "txtName1", "txtAddr1")

    Call Bpca_Registration

    txtName1.SetFocus
 End Sub

 Private Sub UserForm_Terminate()
    Set colAddCtrl = Nothing
    Call Bpca_Clear
 End Sub

 '---------------------------------------------------------
 Private Sub cmdAddLine_Click()
 Dim ctlLbl As MSForms.Label
 Dim ctlChk As MSForms.CheckBox
 Dim ctlTxtName As MSForms.TextBox
 Dim ctlTxtAddr As MSForms.TextBox
 Dim vntArray As Variant
 Dim j As Integer

    If (colAddCtrl.Count = 5) Then  ' Max 5 line
        Beep
        Exit Sub
    End If

    j = colAddCtrl.Count + 1

    Set ctlLbl = Me.Controls.Add("Forms.Label.1")
    With ctlLbl
        .Name = "lblNo" & j
        .Top = 56 + 30 * (j - 1)
        .Left = 12
        .Height = 12
        .Width = 24
        .Caption = "( " & j & " )"
    End With

    Set ctlChk = Me.Controls.Add("Forms.CheckBox.1")
    With ctlChk
        .Name = "chkEnable" & j
        .Top = 54 + 30 * (j - 1)
        .Left = 45
        .Height = 20
        .Width = 20
        .Caption = ""
        .Value = True
    End With

    Set ctlTxtName = Me.Controls.Add("Forms.TextBox.1")
    With ctlTxtName
        .Name = "txtName" & j
        .Top = 54 + 30 * (j - 1)
        .Left = 72
        .Height = 18
        .Width = 54
        .Enabled = True
        .Value = ""
    End With

    Set ctlTxtAddr = Me.Controls.Add("Forms.TextBox.1")
    With ctlTxtAddr
        .Name = "txtAddr" & j
        .Top = 54 + 30 * (j - 1)
        .Left = 135
        .Height = 18
        .Width = 54
        .Enabled = True
        .Value = ""
    End With

    colAddCtrl.Add Array(ctlLbl.Name, ctlChk.Name, ctlTxtName.Name, ctlTxtAddr.Name)

    '追加コントロール(chkEnableX & txtNameX & txtAddrX)の反映の為にリセットする
    Call Bpca_Clear
    Call Bpca_Registration

    ctlTxtName.SetFocus
 End Sub

 '---------------------------------------------------------
 Private Sub cmdEraseLine_Click()
 Dim vntArray As Variant
 Dim j As Integer

    If (colAddCtrl.Count = 1) Then
        Beep
        Exit Sub
    End If

    '削除の場合は、[Bpca_Clear > Control-Remove > Bpca_Registration]の順で実行してください。

    Call Bpca_Clear

    For j = colAddCtrl.Count To 2 Step -1
        vntArray = colAddCtrl(j)
        Me.Controls.Remove vntArray(0)      'lblNo
        Me.Controls.Remove vntArray(1)      'chkEnable
        Me.Controls.Remove vntArray(2)      'txtName
        Me.Controls.Remove vntArray(3)      'txtAddr
    Next j

    chkEnable1.Value = True
    With txtName1
        .Enabled = True
        .Value = ""
    End With
    With txtAddr1
        .Enabled = True
        .Value = ""
    End With

    Set colAddCtrl = Nothing
    Set colAddCtrl = New Collection
    colAddCtrl.Add Array("lblNo1", "chkEnable1", "txtName1", "txtAddr1")

    Call Bpca_Registration

    Call DisplayListBox("---------- Erase (2)-(5) lines ----------")
    txtName1.SetFocus
 End Sub
 '---------------------------------------------------------
 Private Sub AddChkEnable_OnEnter(ByVal Index As Integer)
    With AddChkEnable.Item(Index)
        .BackColor = &HFFFFE0    'LightCyan
        Call DisplayListBox(.Name & " : Enter Value=" & .Value)
    End With
 End Sub

 Private Sub AddChkEnable_Change(ByVal Index As Integer)
    With AddChkEnable.Item(Index)
        Call DisplayListBox(.Name & " : Change Value=" & .Value)
    End With

    'CheckBoxと同じ行のTextBoxには同じIndex番号が割り振られている
    AddTxtName.Item(Index).Enabled = AddChkEnable.Item(Index).Value
    AddTxtAddr.Item(Index).Enabled = AddChkEnable.Item(Index).Value
 End Sub

 Private Sub AddChkEnable_OnExit(ByVal Index As Integer, ByVal Cancel As MSForms.ReturnBoolean)
    With AddChkEnable.Item(Index)
        .BackColor = vbButtonFace
        Call DisplayListBox(.Name & " : Exit Value=" & .Value)
    End With
 End Sub
 '---------------------------------------------------------
 Private Sub AddTxtName_OnEnter(ByVal Index As Integer)
    With AddTxtName.Item(Index)
        .BackColor = &HFFFFE0    'LightCyan
        Call DisplayListBox(.Name & " : Enter Value=" & .Value)
    End With
 End Sub

 Private Sub AddTxtName_Change(ByVal Index As Integer)
    With AddTxtName.Item(Index)
        Call DisplayListBox(.Name & " : Change Value=" & .Value)
    End With
 End Sub

 Private Sub AddTxtName_OnExit(ByVal Index As Integer, ByVal Cancel As MSForms.ReturnBoolean)
    With AddTxtName.Item(Index)
        .BackColor = vbWindowBackground
        Call DisplayListBox(.Name & " : Exit Value=" & .Value)
    End With
 End Sub
 '---------------------------------------------------------
 Private Sub AddTxtAddr_OnEnter(ByVal Index As Integer)
    With AddTxtAddr.Item(Index)
        .BackColor = &HFFFFE0    'LightCyan
        Call DisplayListBox(.Name & " : Enter Value=" & .Value)
    End With
 End Sub

 Private Sub AddTxtAddr_Change(ByVal Index As Integer)
    With AddTxtAddr.Item(Index)
        Call DisplayListBox(.Name & " : Change Value=" & .Value)
    End With
 End Sub

 Private Sub AddTxtAddr_OnExit(ByVal Index As Integer, ByVal Cancel As MSForms.ReturnBoolean)
    With AddTxtAddr.Item(Index)
        .BackColor = vbWindowBackground
        Call DisplayListBox(.Name & " : Exit Value=" & .Value)
    End With
 End Sub
 


[ この場所へのリンク ]
ワークシート上のコントロールへの適用例    2020/9/1 追加

Video capture ( Bpca_SheetControlEvent.mp4   238KB )
( 補足 )
  ワークブック を開いたら、即、clsBpca 適用のイベントが動作するようにする為には、WorkBook_Open で
  初期処理を実行して、シート上のコントロールを clsBpca のオブジェクト変数に取り込む必要があります。

  WorkBook_Open で処理するのですから、clsBpca のオブジェクト変数 は WorkBook_Open がある
  ThisWorkbook モジュールにて定義する必要があります。

  clsBpca オブジェクト が ThisWorkbook モジュールで定義されているので、当然、そのイベントプロシ
  ジャー も Thisworkbook モジュールで記述する事になります。

  Thisworkbook や Sheet1 モジュール などで、Public 宣言で変数定義しても、そのモジュール以外からは
  参照できません （Public と書いても Private 扱いです）。
【 ThisWorkbook モジュール 】

 '----- clsBpca : シート上のコントロールの利用例 -----

 Private WithEvents Bpca_ShCmd As clsBpca

 'フレームの代わりにラベルコントロール(lblFrame)を使う
 'lblFrameの処理をSheet1モジュール内に記述しても良いが、
 'このモジュール内で完結させる為に、lblFrame単独でclsBpcaを適用する
 Private WithEvents Bpca_ShLbl As clsBpca

 '---------------------------------------------------------
 Private Sub Workbook_Open()
     Set Bpca_ShCmd = New clsBpca    ' インスタンスの生成
     Set Bpca_ShLbl = New clsBpca

     ;' [ ワークシート.OLEObjects(コントロール名).Object ]のスタイルで指定します
     With Worksheets("Sheet1")
         Bpca_ShCmd.Add  .OLEObjects("CommandButton5").Object
         Bpca_ShCmd.Add  .OLEObjects("CommandButton6").Object
         Bpca_ShCmd.Add  .OLEObjects("CommandButton7").Object
         Bpca_ShCmd.Add  .OLEObjects("CommandButton8").Object
         Bpca_ShCmd.Rgst  BPCA_Click + BPCA_MouseMove

         Bpca_ShLbl.Add  .OLEObjects("lblFrame").Object
         Bpca_ShLbl.Rgst  BPCA_MouseMove
     End With
 End Sub

 '---------------------------------------------------------
 Private Sub Workbook_BeforeClose(Cancel As Boolean)
     'VBAプロジェクトのリセットにより、
     'オブジェクト変数(Bpca_ShCmd,Bpca_ShLbl)が初期化されている
     '場合(実行時エラーになる)に備えて[ On Error Resume Next ]を必ず記述する
     On Error Resume Next
     Bpca_ShCmd.Clear
     Bpca_ShLbl.Clear
     Set Bpca_ShCmd = Nothing
     Set Bpca_ShLbl = Nothing
 End Sub

 '---------------------------------------------------------
 Private Sub Bpca_ShCmd_Click(ByVal Index As Integer)
     MsgBox "[ clsBpca ] シート上コントロールの利用例" & vbCrLf & vbCrLf & _
                 Bpca_ShCmd.ItmCmd(Index).Caption & "が押されました", vbInformation

     Bpca_ShCmd.ItmCmd(Index).BackColor = &H99FFFF    '薄黄色
 End Sub

 '---------------------------------------------------------
 Private Sub Bpca_ShCmd_MouseMove(ByVal Index As Integer, ByVal Button As Integer, _
                                  ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 Dim i As Integer

     For i = 1 To Bpca_ShCmd.Count
         With Bpca_ShCmd.ItmCmd(i)
             If (i = Index) Then
                 If (.BackColor = &H99FFFF) Then
                     .BackColor = &HCC99FF    '薄赤色
                 End If
             Else
                 If (.BackColor <> &H99FFFF) Then
                     .BackColor = &H99FFFF    '薄黄色
                 End If
             End If
         End With
     Next i
 End Sub

 '---------------------------------------------------------
 '全てのコマンドボタンからマウスが外れた事を検知する為に
 'ラベルコントロール(lblFrame)をフレーム代わりに使う
 Private Sub Bpca_ShLbl_MouseMove(ByVal Index As Integer, ByVal Button As Integer, _
                                  ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 Dim i As Integer

     For i = 1 To Bpca_ShCmd.Count
         With Bpca_ShCmd.ItmCmd(i)
             If (.BackColor <> &H99FFFF) Then
                 .BackColor = &H99FFFF    '薄黄色
             End If
         End With
     Next i
 End Sub
 

  ====================================================================
    ヾ(＾v＾)k  終わりで〜す  (^-^)/~~  
  ====================================================================

・・・と、その前に、
最後に残されていた Enter/Exit イベントの実装が可能になりました (2014/8/11)。
その仕組みの解説は「汎用クラス」ページの特集記事（便宜上、次頁・§１２扱い）を参照。

[ 前頁 , 次頁 , §１ , §２ , §３ , §４ , §５ , §６ , §７ , §８ , §９ , §１０ , §１１ , §１２ ]
[ 汎用クラス , トグルラベル クラス , Focus クラス , クラス アドイン , カレンダークラス ] [ 質問はメールへ ]

[ Home へ戻る ]

ロゴ（ゴールド） ロゴ（ゴールド）
角田　桂一 Mail:addinbox@h4.dion.ne.jp CopyRight(C) 2004 Allrights Reserved.