ロゴ(青) 擬似からの脱却 ロゴ(緑)

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

[ clsBpca の 軌跡 ] [ 前頁 , 次頁 , §1 , §2 , §3 , §4 , §5 , §6 , §7 , §8 , §9 , §10 , §11 , §12 ]
[ 汎用クラス , トグルラベル クラス , Focus クラス , クラス アドイン , カレンダークラス ] [ 質問はこちら]

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

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


(前節より‥‥‥)
      最後に、この「擬似からの脱却」手法の汎用クラスモジュール【 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 追加

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



[ この場所へのリンク ]

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

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

  クラスモジュールで Enter/Exit イベントを受け取る
  仕組みは §12 を参照

  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
 


[ この場所へのリンク ]

  『 電 卓 』
  06/09/20    クリア後に '0' を連続した場合、1個の '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
          '[AC]
          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
 


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

  七曜暦レイアウトの作成方法はこちら参照
カレンダークラスアドイン」を使えば、もっと簡単にカレンダーフォームを作れます。

下記コードにおいて茶色で示されている『祝日表示』コードの部分は、[汎用クラス]ブック
には含まれていませんので、このページからコピーして下さい(祝日の日付が[赤]になり、
コントロールチップテキストに祝日名がセットされます)。尚、その際には
        『祝日判定ロジック(ktHolidayName 関数)
が必要になります。標準モジュールを用意し、そこに祝日判定ロジック(VBA)をコピーし
て下さい。(2004/7/17 追記)
2005/5/20 祝日判定ロジックを 「昭和の日」 対応で 修正してありますので差し替えてください。
※ 2014/5/29 祝日判定ロジックを 「山の日」 対応で 修正してありますので差し替えてください。

  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_V30.zip > Export_V30 > 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



[ この場所へのリンク ]


都道府県 選択ツール『日本地図フォーム』  (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]イベントは発生しないように作ってあります)。

チェックボックスコントロールも、下記と同様の処理で排他機能を持たせることが可能です。


 '=== 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 追加

2〜5行目のコントロールセットを動的に作成します(1行目はデザイン時に作成済)。
追加したコントロールを削除して初期状態に戻す事もできます。
[ 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()
    'デザイン時に用意されている1行目(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
 

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

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

[ 前頁 , 次頁 , §1 , §2 , §3 , §4 , §5 , §6 , §7 , §8 , §9 , §10 , §11 , §12 ]
[ 汎用クラス , トグルラベル クラス , Focus クラス , クラス アドイン , カレンダークラス ] [ 質問はこちら]


[ Home へ戻る ]

ロゴ(ゴールド) ロゴ(ゴールド)

角田 桂一 Mail:addinbox@h4.dion.ne.jp CopyRight(C) 2004 Allrights Reserved.