スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

自前スクロールバーをクラス化してみた 


前の記事 自前スクロールバー をクラス化してみた。
クラス化を考えてみると、処理を細かい関数にして双方のフォームから呼び合う・・・・
この関数の分割、処理の記述場所が適当なのか・・・・これ、結構わかります。

前記事について言えば、
RGB の色を表示する部分(関数)を、メイン/サブ双方から呼び合うようにしていました。
クラス化を考えた時、色表示はメインに任せ、クラスとしてはそれに必要な情報を通知する・・・
と、思います。

縦スクロールバー用のクラス「clsSBV」、横スクロールバー用のクラス「clsSBH」に分けて作ってみました。
フォームの構成は、
・サブフォームコントロールを用意してもらって
・クラスにそのコントロールを指定してもらうと、連携するフォームを適宜組み込んで・・・

今回余計な処理として、クラスが扱うフォーム(サブ用)がなかったら、新規作成して・・・
前記事でサブフォーム側にコントロールが必要なのかと思ってコマンドボタンを付けていましたが、
大元のフォームのサイズだけで良いみたいなので、今回コントロールの配置はしていません。

今回、確認用で用意したフォームは6つ
・前回の RGB 構成のもの「F1」「F2」
kEnt112_F1  kEnt112_F2

・縦/横スクロールバー切り換え、レンジ確認用「FT1」「FT2」
kEnt112_FT1  kEnt112_FT2

・サブフォームコントロールサイズを変更した時のもの「FT3」「FT4」
kEnt112_F3  kEnt112_F4

フォーム「FT3」を、2000 / 2003 で見た時の表示は
kEnt112_FT3_2000  kEnt112_FT3_2003
 

クラス


まず、縦用スクロールバークラス「clsSBV」の全部を見ていただいてから
Private Const MyFormName As String = "F_SBV"
Private Const MyHeight As Long = 15 * 567

Private Const MyInterval As Long = 20
Private Const MyCountLimit As Long = 50
Private Const EVENT_PROCEDURE As String = "[EVENT PROCEDURE]"

Public Event Change(ByVal Value As Long)

Private WithEvents frmSub As SubForm
Private WithEvents frmMy As Form
Private ctlGoFocus As Control
Dim iSubSave As Long
Dim iMyLow As Long
Dim iMyMax As Long
Dim iMyMove As Long
Dim iMyPos As Long
Dim iMyCount As Long

Private Sub Class_Initialize()
  iMyLow = 0
  iMyMax = 255
End Sub

Private Sub Class_Terminate()
  Call Me.Clear
End Sub

Public Sub Clear()
  On Error Resume Next
  If (Not frmSub Is Nothing) Then
    With frmSub
      .OnEnter = ""
      .OnExit = ""
      .SourceObject = ""
      .Width = iSubSave
    End With
    Set frmSub = Nothing
  End If
  Set frmMy = Nothing
  Set ctlGoFocus = Nothing
End Sub

Private Sub MakeForm()
  Dim sFN As String

  With CreateForm
    .DefaultView = 0
    .RecordSelectors = False
    .ScrollBars = 2
    .NavigationButtons = False
    .Section(acDetail).Height = MyHeight
    .Width = 10
    .HasModule = True
    sFN = .Name
  End With
  DoCmd.Close acForm, sFN, acSaveYes
  DoCmd.Rename MyFormName, acForm, sFN
End Sub

Private Sub frmMy_Timer()
  On Error Resume Next
  If (iMyPos = frmMy.CurrentSectionTop) Then
    iMyCount = iMyCount + 1
    If (iMyCount > MyCountLimit) Then
      If (Not ctlGoFocus Is Nothing) Then
        frmMy.TimerInterval = 0
        ctlGoFocus.SetFocus
      End If
    End If
    Exit Sub
  End If
  iMyCount = 0
  iMyPos = frmMy.CurrentSectionTop
  RaiseEvent Change(Me.Value)
End Sub

Private Sub frmSub_Enter()
  iMyCount = 0
  frmMy.TimerInterval = MyInterval
End Sub

Private Sub frmSub_Exit(Cancel As Integer)
  frmMy.TimerInterval = 0
End Sub

Public Sub Bind(frmS As SubForm, ctl As Control _
        , Optional iLow As Variant, Optional iMax As Variant _
        , Optional iVal As Variant)
  Dim oAcc As Object
  Dim bNotFound As Boolean

  On Error Resume Next
  If (Not IsMissing(iLow)) Then iMyLow = iLow
  If (Not IsMissing(iMax)) Then iMyMax = iMax
  If (iMyLow >= iMyMax) Then Call Class_Initialize

  If (Not frmSub Is Nothing) Then Me.Clear
  Set frmSub = frmS
  Set ctlGoFocus = ctl

  bNotFound = True
  For Each oAcc In CurrentProject.AllForms
    If (oAcc.Name = MyFormName) Then
      bNotFound = False
      Exit For
    End If
  Next
  If (bNotFound) Then MakeForm

  If (Not frmSub Is Nothing) Then
    With frmSub
      iSubSave = .Width
      .Width = 270
      .SourceObject = MyFormName
      Set frmMy = .Form
      If (Not frmMy Is Nothing) Then
        iMyMove = .Height - frmMy.Section(acDetail).Height + 10
        .OnEnter = EVENT_PROCEDURE
        .OnExit = EVENT_PROCEDURE
        If (Not IsMissing(iVal)) Then Me.Value = iVal
        frmMy.OnTimer = EVENT_PROCEDURE
      End If
    End With
  End If
End Sub

Public Sub Range(iLow As Long, iMax As Long)
  If (iLow < iMax) Then
    iMyLow = iLow
    iMyMax = iMax
  End If
End Sub

Public Property Let Value(iValue As Long)
  Dim ctl As Control
  Dim i As Long

  On Error Resume Next
  If (frmSub Is Nothing) Then Exit Property
  If (frmMy Is Nothing) Then Exit Property

  frmMy.OnTimer = ""
  Set ctl = Screen.ActiveControl
  frmSub.SetFocus
  i = Int(-iMyMove / Abs(iMyMax - iMyLow) * (iValue - iMyLow))
  DoCmd.GoToPage 1, , i
  iMyPos = frmMy.CurrentSectionTop

  If (Not ctl Is Nothing) Then ctl.SetFocus
  Set ctl = Nothing
  frmMy.OnTimer = EVENT_PROCEDURE
End Property

Public Property Get Value() As Long
  Dim i As Long

  On Error Resume Next
  i = Int(iMyPos / iMyMove * Abs(iMyMax - iMyLow)) + iMyLow
  If (i > iMyMax) Then i = iMyMax
  Value = i
End Property

 
クラスで使用するフォーム名、フォームがなかったらどの大きさで作成するか
Private Const MyFormName As String = "F_SBV"
Private Const MyHeight As Long = 15 * 567
で、記述しています。

このクラスで用意したメソッドは、
「Clear」「Bind」「Range」の3つと、「Value」のプロパティ1つ。

Clear
Range 情報以外をクリアするもの(表示していれば関連付けを解消)

Bind
どのサブフォームコントロールに表示するか等々指定します
Public Sub Bind(frmS As SubForm, ctl As Control _
        , Optional iLow As Variant, Optional iMax As Variant _
        , Optional iVal As Variant)
サブフォームコントロール, フォーカス移動用コントロール, 最小値, 最大値, 初期値
 
指定されたサブフォームコントロールへは、
・「OnEnter」「OnExit」イベントを設定します
・「SourceObject」にサブ用フォームを設定します
・スクロールバー表示に必要な大きさに、サブフォームのサイズを調整します
(縦用の場合は「幅」を、横用の場合は「高さ」を)
サブ用のフォームで使用するイベントは、「タイマ時」のみになります。

Range
スクロールバーに割付ける最小値/最大値を指定します。
Bind 時でも指定は可能です。

Value
スクロールバーの値を設定/取得します。

クラスからの通知
スクロールバーの動きに変化があるか「タイマ時」で周期的に確認していきますが、
変化があった場合、「Change」イベントを介して通知するようにします。
メイン側では、
Dim WithEvents R As clsSBV

  Set R = New clsSBV ' クラスの設定
  R.Bind Me.FSUB1, Me.btn1, 0, 255, Me.txt1

Private Sub R_Change(ByVal Value As Long) ' クラスからの通知
  Me.txt1 = Value
  Call ShowColor
End Sub
クラス側では
Public Event Change(ByVal Value As Long)

  RaiseEvent Change(Me.Value)

Public Property Get Value() As Long
  Dim i As Long

  On Error Resume Next
  i = Int(iMyPos / iMyMove * Abs(iMyMax - iMyLow)) + iMyLow
  If (i > iMyMax) Then i = iMyMax
  Value = i
End Property
のような感じで、スクロールバーの現在値を通知します。

「タイマ時」はサブフォームコントロールがフォーカスを得てから動きだしますが、
同じ値を取り続けた場合、フォーカスを他に移動します。
Private Const MyInterval As Long = 20
Private Const MyCountLimit As Long = 50

Private Sub frmMy_Timer()
  On Error Resume Next
  If (iMyPos = frmMy.CurrentSectionTop) Then
    iMyCount = iMyCount + 1
    If (iMyCount > MyCountLimit) Then
      If (Not ctlGoFocus Is Nothing) Then
        frmMy.TimerInterval = 0
        ctlGoFocus.SetFocus
      End If
    End If
    Exit Sub
  End If
  iMyCount = 0
  iMyPos = frmMy.CurrentSectionTop
  RaiseEvent Change(Me.Value)
End Sub

Private Sub frmSub_Enter()
  iMyCount = 0
  frmMy.TimerInterval = MyInterval
End Sub

Private Sub frmSub_Exit(Cancel As Integer)
  frmMy.TimerInterval = 0
End Sub
 
横スクロール用クラス「clsSBH」は、これの横バージョンになります。
(クラスを1つにして、パラメータにより縦/横切り換える方法にはしてません)

なお、クラスで使用するサブ用フォームは「F_SBH」「F_SBV」になります。
もちろん、クラス内の記述を変更すればこの限りではありません。

確認用フォーム「F1」「F2」

kEnt112_F1  kEnt112_F2

これは前回の記事のフォームを流用して、クラス化した記述に変更したものになります。
Dim WithEvents R As clsSBV
Dim WithEvents G As clsSBV
Dim WithEvents B As clsSBV

Private Function ShowColor()
  Me.lab00.BackColor = RGB(Me.txt1, Me.txt2, Me.txt3)
End Function

Private Function BeforeShowColor(iNum As Integer)
  Select Case iNum
    Case 1: R.Value = Me.txt1
    Case 2: G.Value = Me.txt2
    Case 3: B.Value = Me.txt3
  End Select
  Call ShowColor
End Function

Private Sub Form_Load()
  Dim i As Integer

  For i = 1 To 3
    With Me("txt" & i)
      .TextAlign = 3
      .Value = 0
      .ValidationRule = "Not Like '*[!0-9]*' And >=0 And <=255"
      .ValidationText = "整数値で 0 ~ 255 の範囲で入力して"
      .AfterUpdate = "=BeforeShowColor(" & i & ")"
    End With
  Next
  Set R = New clsSBV
  R.Bind Me.FSUB1, Me.btn1, 0, 255, Me.txt1
  Set G = New clsSBV
  G.Bind Me.FSUB2, Me.btn1, 0, 255, Me.txt2
  Set B = New clsSBV
  B.Bind Me.FSUB3, Me.btn1, 0, 255, Me.txt3
  Call ShowColor
  Me.btn1.SetFocus
End Sub

Private Sub R_Change(ByVal Value As Long)
  Me.txt1 = Value
  Call ShowColor
End Sub
Private Sub G_Change(ByVal Value As Long)
  Me.txt2 = Value
  Call ShowColor
End Sub
Private Sub B_Change(ByVal Value As Long)
  Me.txt3 = Value
  Call ShowColor
End Sub
 

確認用フォーム「FT1」「FT2」

kEnt112_FT1  kEnt112_FT2

このフォームは動作確認の主たるものになります。
・どちら方向のスクロールバーを使うか
・途中、最小値/最大値を設定してみて・・・・
(設定するだけでは値を得ていないので、単独で得てみるとか・・・)

以下は、フォーム「FT1」の記述になります。
Dim WithEvents sbH As clsSBH
Dim WithEvents sbV As clsSBV

Private Sub Form_Load()
  Dim i As Integer

  For i = 1 To 3
    With Me("txt" & i)
      .ValidationRule = "Not Like '*[!-0-9]*'"
      .ValidationText = "数値を入力して"
    End With
  Next

  Me.txt1 = 50
  Me.txt2 = 0
  Me.txt3 = 100
  Me.op1 = 1
  Call op1_Click
End Sub

Private Sub op1_Click()
  Select Case Me.op1
    Case 1
      If (Not sbH Is Nothing) Then sbH.Clear
      If (sbV Is Nothing) Then Set sbV = New clsSBV
      sbV.Bind Me.FSUB, Me.btn2, Me.txt2, Me.txt3, Me.txt1
    Case 2
      If (Not sbV Is Nothing) Then sbV.Clear
      If (sbH Is Nothing) Then Set sbH = New clsSBH
      sbH.Bind Me.FSUB, Me.btn2, Me.txt2, Me.txt3, Me.txt1
  End Select
End Sub

Private Sub sbH_Change(ByVal Value As Long)
  Me.txt1 = Value
End Sub

Private Sub sbV_Change(ByVal Value As Long)
  Me.txt1 = Value
End Sub

Private Sub txt1_AfterUpdate()
  Select Case Me.op1
    Case 1: sbV.Value = Me.txt1
    Case 2: sbH.Value = Me.txt1
  End Select
End Sub

Private Sub btn1_Click()
  Select Case Me.op1
    Case 1: sbV.Range Me.txt2, Me.txt3
    Case 2: sbH.Range Me.txt2, Me.txt3
  End Select
End Sub

Private Sub btn2_Click()
  Select Case Me.op1
    Case 1: Me.lab1.Caption = sbV.Value
    Case 2: Me.lab1.Caption = sbH.Value
  End Select
End Sub
 
フォーム「FT1」とフォーム「FT2」の違いは
Private Sub op1_Click()
  Select Case Me.op1
    Case 1
      If (Not sbH Is Nothing) Then sbH.Clear
      If (sbV Is Nothing) Then Set sbV = New clsSBV
      sbV.Bind Me.FSUB, Me.btn2, Me.txt2, Me.txt3, Me.txt1
    Case 2
      If (Not sbV Is Nothing) Then sbV.Clear
      If (sbH Is Nothing) Then Set sbH = New clsSBH
      sbH.Bind Me.FSUB, Me.btn2, Me.txt2, Me.txt3, Me.txt1
  End Select
End Sub
上側がフォーム「FT1」、下側がフォーム「FT2」で異なる部分
Private Sub op1_Click()
  Select Case Me.op1
    Case 1
      If (Not sbH Is Nothing) Then Set sbH = Nothing
      Set sbV = New clsSBV
      sbV.Bind Me.FSUB, Me.btn2, Me.txt2, Me.txt3, Me.txt1
    Case 2
      If (Not sbV Is Nothing) Then Set sbV = Nothing
      Set sbH = New clsSBH
      sbH.Bind Me.FSUB, Me.btn2, Me.txt2, Me.txt3, Me.txt1
  End Select
End Sub
 
要は、クラスの扱い方だけです。
「Clear」で使い回しするか、都度 Set sbV = New clsSBV の様に新規にするか


確認用フォーム「FT3」

kEnt112_F3

サブフォームコントロールの大きさを変えて、スクロールバーのスライド部分の大きさを
確認しましょう・・・・というもの。
大きくなるとスライド部分は大きくなりますね。

また、各スクロール3本の真ん中では、値を逆転して扱いましょう・・・というもの。
クラスへの設定は変わらないので、メイン側の処理で対応します。
Private Const MyLow As Long = 0
Private Const MyMax As Long = 255

Dim WithEvents VSB1 As clsSBV
Dim WithEvents VSB2 As clsSBV
Dim WithEvents VSB3 As clsSBV
Dim WithEvents HSB4 As clsSBH
Dim WithEvents HSB5 As clsSBH
Dim WithEvents HSB6 As clsSBH


Private Sub Form_Load()
  Dim i As Integer

  For i = 1 To 6
    With Me("txt" & i)
      .ValidationRule = "Not Like '*[!-0-9]*'"
      .ValidationText = "数値を入力して"
      Select Case i
        Case 1, 3, 4, 6
          .Value = i * 20
        Case 2, 5
          .Value = MyMax - i * 20
      End Select
    End With
  Next

  Set VSB1 = New clsSBV
  VSB1.Bind Me.FSUB1, Me.btn1, MyLow, MyMax, Me.txt1
  Set VSB2 = New clsSBV
  VSB2.Bind Me.FSUB2, Me.btn1, MyLow, MyMax, Me.txt2
  Set VSB3 = New clsSBV
  VSB3.Bind Me.FSUB3, Me.btn1, MyLow, MyMax, Me.txt3
  Set HSB4 = New clsSBH
  HSB4.Bind Me.FSUB4, Me.btn1, MyLow, MyMax, Me.txt4
  Set HSB5 = New clsSBH
  HSB5.Bind Me.FSUB5, Me.btn1, MyLow, MyMax, Me.txt5
  Set HSB6 = New clsSBH
  HSB6.Bind Me.FSUB6, Me.btn1, MyLow, MyMax, Me.txt6
End Sub

Private Sub txt1_AfterUpdate()
  VSB1.Value = Me.txt1
End Sub
Private Sub txt2_AfterUpdate()
  VSB2.Value = MyMax - Me.txt2
End Sub
Private Sub txt3_AfterUpdate()
  VSB3.Value = Me.txt3
End Sub
Private Sub txt4_AfterUpdate()
  HSB4.Value = Me.txt4
End Sub
Private Sub txt5_AfterUpdate()
  HSB5.Value = MyMax - Me.txt5
End Sub
Private Sub txt6_AfterUpdate()
  HSB6.Value = Me.txt6
End Sub

Private Sub VSB1_Change(ByVal Value As Long)
  Me.txt1 = Value
End Sub
Private Sub VSB2_Change(ByVal Value As Long)
  Me.txt2 = MyMax - Value
End Sub
Private Sub VSB3_Change(ByVal Value As Long)
  Me.txt3 = Value
End Sub
Private Sub HSB4_Change(ByVal Value As Long)
  Me.txt4 = Value
End Sub
Private Sub HSB5_Change(ByVal Value As Long)
  Me.txt5 = MyMax - Value
End Sub
Private Sub HSB6_Change(ByVal Value As Long)
  Me.txt6 = Value
End Sub

Private Sub btn1_Click()
  Dim i As Integer

  For i = 1 To 6
    With Me("txt" & i)
      .SetFocus
      Select Case i
        Case 1, 3, 4, 6
          .Text = i * 20
        Case 2, 5
          .Text = MyMax - i * 20
      End Select
    End With
  Next
  Me.btn1.SetFocus
End Sub
 

確認用フォーム「FT4」

kEnt112_F4

フォーム「FT3」を流用して、縦用/横用のクラスは1つだけにして、
それを必要な時に各サブフォームコントロールに割付けましょう・・・・というもの。
割付けるタイミングは、テキストボックスの数値を変更した時・・・
また、各サブフォームコントロールの大きさを大きめにしておいて、
スクロールバーが表示された時の大きさと比べてみる・・・

また、クラスの使い方も、
  Set VSB = New clsSBV: VSB.Range MyLow, MyMax

      iV = iNum
      VSB.Bind Me("FSUB" & iNum), Me.btn1
      If (iNum = 2) Then
        VSB.Value = MyMax - Me.txt2
      Else
        VSB.Value = Me("txt" & iNum)
      End If
のように、各指定をバラバラにしてやってみた。
また、Bind での指定を上書き・上書き・・・・の様に使ってみた。
Private Const MyLow As Long = 0
Private Const MyMax As Long = 255

Dim WithEvents VSB As clsSBV
Dim WithEvents HSB As clsSBH

Dim iV As Integer
Dim iH As Integer


Private Function TextAfter(iNum As Integer)
  Select Case iNum
    Case 1, 2, 3
      iV = iNum
      VSB.Bind Me("FSUB" & iNum), Me.btn1
      If (iNum = 2) Then
        VSB.Value = MyMax - Me.txt2
      Else
        VSB.Value = Me("txt" & iNum)
      End If
    Case 4, 5, 6
      iH = iNum
      HSB.Bind Me("FSUB" & iNum), Me.btn1
      If (iNum = 5) Then
        HSB.Value = MyMax - Me.txt5
      Else
        HSB.Value = Me("txt" & iNum)
      End If
  End Select
End Function

Private Sub Form_Load()
  Dim i As Integer

  For i = 1 To 6
    With Me("txt" & i)
      .ValidationRule = "Not Like '*[!-0-9]*'"
      .ValidationText = "数値を入力して"
      .AfterUpdate = "=TextAfter(" & i & ")"
    End With
  Next
  Call btn1_Click
End Sub

Private Sub VSB_Change(ByVal Value As Long)
  If (iV = 2) Then
    Me.txt2 = MyMax - Value
  Else
    Me("txt" & iV) = Value
  End If
End Sub
Private Sub HSB_Change(ByVal Value As Long)
  If (iH = 5) Then
    Me.txt5 = MyMax - Value
  Else
    Me("txt" & iH) = Value
  End If
End Sub

Private Sub btn1_Click()
  Dim i As Integer

  Set VSB = Nothing
  Set HSB = Nothing

  For i = 1 To 6
    With Me("txt" & i)
      .SetFocus
      Select Case i
        Case 1, 3, 4, 6
          .Value = i * 20
        Case 2, 5
          .Value = MyMax - i * 20
      End Select
    End With
  Next
  Me.btn1.SetFocus

  Set VSB = New clsSBV: VSB.Range MyLow, MyMax
  Set HSB = New clsSBH: HSB.Range MyLow, MyMax
End Sub

 

※ 試される時には、一度、フォーム「F_SBH」「F_SBV」を削除してからやってみてください
(存在しなかったら作成して処理を続けます)
また、その際、フォームの大きさを変更してみるとか・・・・
(現在は 15cm になっています)
その後、スクロールバーのスライド部分の大きさも見てみてください。

※ そこそこの値が欲しい時にしか使えないと思います。
(設定した値が、そのまま得られる保証はないので)
でも、スクロールバーって、そんなものと思えば・・・・

そうそう、エラーのチェック等ほとんどしていないので、使われるのなら手直し/見直しが必要と思います。

サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt112_2000.zipkEnt112_2003.zipkEnt112_2007.zip
 サイズ 58,78855,58558,083
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2011/12/11

Category: 使えたら

TB: 0  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △

トラックバック

トラックバックURL
→http://kikutips.blog13.fc2.com/tb.php/112-c9dd16fc
この記事にトラックバックする(FC2ブログユーザー)

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。