|
|
|
(注) 2005/11/25 公開の版 (Ver 1, MOUGでの公開版) とは、仕様/インターフェースが異なっています。
( Ver 3.0 で x64 対応となりました )
Ver 3.1 で ７セグメント時計の
サンプルを追加しました。
VBでは「ある時間経過後にイベントを発生」させる『タイマーコントロール』というものが
利用できますが、残念ながら VBAではサポートされていません。
したがって、VBAで待機処理させる場合には OnTime メソッド や Wait メソッド、または
API の Sleep 関数を使う事になります。Wait メソッドと Sleep 関数ではVBA処理そのもの
を停止させますので、待機中に平行して別の処理を行なう事はできません。OnTime メソッ
ドの場合には待機中に平行して別の処理が行なえますが単発機能ですので、繰り返し
待機処理させる場合には、待機から戻ってきた時点で再度OnTime メソッドを実行するとい
う処理になります。タイマーコントロールならば、指定時間経過の時点でタイマーイベントル
ーチンをシステム側が自動的に起動させるまでの間、ユーザーサイドで他の処理を実行す
る事が可能ですし、タイマーを停止させるまでは時間経過の都度、繰り返して処理されます。
タイマーコントロールがあれば簡単に出来るのに VBA では実現できなかった一例として
は、UserForm上にリアルタイムで時を刻む『時計』を配置しつつテキストボックスやコマンド
ボタン等のユーザー操作のイベント処理も行なう、ユーザー操作を行ないつつ一定の時間
経過時点でMsgBox を表示する、といったものがあるでしょう。
ここで紹介するのは、MOUG/VBA掲示板において「平さん」が提示したクラスモジュール
を利用してタイマーコントロールを実現するコードを、私が改良/汎用化させたものです。
【 注 意 事 項 (必ずお読み下さい) 】
以下のプログラムでは 『 コールバック 』 と呼ばれる手法を利用しています。エクセルでは、コールバックで呼ばれた処理の中で「実行時エラー」が発生し中断するとクラッシュする可能性があります。その結果として、ブック破損や未保存情報の喪失（開発中のプログラムやシート上の様々なデータ）が起こる可能性があります。また、コールバックで呼ばれる処理の起動タイミングが 「シート編集作業中」にぶつかると、やはりクラッシュする可能性があります。
以上の事から、このプログラムを利用する場合には、
(1) モーダルフォーム内での利用に限る（モードレスフォーム、シートやThisWorkbook
モジュール、標準モジュールからのタイマー起動は避ける）。つまり、シートの操作が出
来る状況では使用しないという事です（モーダルフォームであれば、フォーム表示中は
シート等の操作は出来ません）。これは必ず厳守してください。
（Ver 2 では、UserForm以外での利用は出来ない仕様になりました）
(2) タイマーイベント内で行なう処理では「実行時エラー」 によって中断する事がないよ
うに充分注意を払って設計/プログラミングを行なう。
(3) テスト中には、実行前に「保存」 を行ない、またタイマーイベント内の処理を最初か
らタイマー連動でテストするような事はせず、単独でテストし、「実行エラー」 などの
バグを事前に確実に取り除く。
といった注意が必要です。
なお、このプログラムでは、コールバックで即 [ RaiseEvent メソッド ] によるイベントへ繋げています。つまり、ユーザーサイドの処理は VBA システムが介在した後のイベントルーチン内で行なわれるものです。したがって、コールバックで直接呼ばれたルーチン内で行なわれるものとは多少扱いが異なるかもしれませんが、確たる保証がありませんので、通常のコールバック処理と同じ注意が必要です。
また、他の大事なブックを開いたままで 「ちょっと、この機能、面白そうだから試してみるか」と安易に試さないでください。大事なブックが失われてしまうかもしれません。
何れにして、以下のプログラムの利用に際しては、
仕組みを充分に理解した上で 『 自己責任 』 において
行なってください。
（利用方法）
１．下記のサンプルブックをダウンロードして、クラスモジュール[ clsTimer ] と標準
モジュール[ TimerModule ] の２つを各自のブックにインポートしてください。
サンプルブック（ TimerControl_V31.zip 58KB ) (2012/3/18 Ver3.1)
2005/11/25 Ver1.0 moug で回答したマクロです。
2005/11/27 Ver2.0 AddinBox 公開に際して、仕様/インターフェースを変更しました。
2011/ 9/27 Ver3.0 Win32-API 処理に [ x64 ] 対応の修正を行ないました。
2012/ 3/18 Ver3.1 利用サンプル に 【 ７セグメント デジタル時計 】 を追加しました。
clsTimer クラス に変更はありません。
====================================================================
[ clsTimer ] クラス リファレンス (2011/ 9/27 Ver 3.0 )
====================================================================
RaiseEvent ステートメント 並びに AddressOf 演算子 を使用していますので、このクラスは
『Excel2000 以上』でのみ利用できます （Excel97 では利用できません）。
このクラスは UserForm モジュールでのみ利用できます。
下記で[ object ]の部分には、clsTimer クラスを定義したオブジェクト変数を記述します。
【 定 義 】 タイマーを使用するUserForm モジュールの宣言セクション（モジュールの先頭）で、下記のように定義
します。尚、その UserForm は必ずモーダルモードで表示してください。モードレスでの利用は障害
を伴う可能性があります。
Private WithEvents object As clsTimer
( object )
任意の名前を指定して下さい。
タイマー実行に先立ち （Initialize イベント等 ）、下記のようにしてクラスのインスタンスを作成します。
Set object = New clsTimer
また、UserForm を閉じる前 （QueryClose イベント等 ） には、下記のようにしてタイマーの停止 および
クラスインスタンスの解放を行ってください。
残っている（未停止の）タイマーの数は Count プロパティで取得できますが、未停止タイマーの有無に
係わらず、無条件で下記を実行するようにしてください。
object .DestroyAll
Set object = Nothing
【 メソッド 】 object .Create Caller , TimerID , Interval
指定した時間間隔のタイマーを起動します。
( Caller )
タイマー処理を組み込む UserForm を指定します。実際には 「Me キーワード」 を指定します。
( TimerID )
任意の 「１ 以上 」 の数値を指定します。複数のタイマーを使用する場合は重複しない番号を割振って
ください。なお、この番号はUserForm 単位で管理していますので、UserForm が異なれば同時実行で
あっても同じ番号を割り当てても構いません。
ここで指定した番号が タイマーイベントで通知されますので、複数のタイマーを使用する場合には、その
番号で処理を振り分けてください。
( Interval )
タイマーイベントの間隔を 『 秒 』 単位で指定します。１秒間ならば １ を指定します。
object .Destroy TimerID , [ OtherHWnd ]
指定した ID のタイマーを停止します。
同時に、タイマー情報を格納したコレクションから、この ID に関する登録情報を削除します。コレクションが
空になった時点で自動的に 「コレクションオブジェクト」 が解放されますので、ユーザーサイドでコレクション
オブジェクトの解放に気を使う必要はありません。以下に説明しているように 「停止忘れ」 が無いように注
意していれば充分です。
このタイマーを利用するプログラムが終了する際 （ UserForm を閉じる際など ） には、必ず、使用した ID に
対して Destroy メソッドを実行してタイマーを停止させてください。停止中の ID に対して Destroy メソッドを
実行しても問題ありませんので、終了時には使用した全ての ID に対して無条件に実行する事をお薦めしま
す（次の DestroyAll メソッドでも構いません）。
( TimerID )
Create メソッドで指定した TimerID を指定します。
( OtherHWnd ) Ver3.0 〜
ユーザーサイドでは 常に省略してください。 （DestroyAll 用のインターフェースです）
省略すると、自UserForm 発行のタイマーが対象になります。
値を指定した場合は、[ その値を Hwnd に持つ UserForm ] が発行したタイマーが対象になります。
※ この Destroy メソッドによって、全て (自UserForm/他UserForm 含めて) のタイマーが破棄された
(稼働中タイマーが全く無い) 場合には、TimerModule にある colClsTimer コレクションオブジェ
クト も合わせて破棄 (Nothing の設定) されます。
ユーザーサイドでは、Destroy / DestroyAll メソッド の実行を確実に行っておけば、TimerModule に
ある colClsTimer コレクションオブジェクト に意識を払う必要はありません。
object .DestroyAll [ OtherForm ]
稼働中の全てのタイマーを 一括して停止/破棄します。
UserForm を閉じる際 ( QueryClose 等 ) に実行してタイマーの停止漏れが無いようにしてください。
( OtherForm ) Ver3.0 〜
False or 省略 : 自UserForm で発行したタイマーのみを一括で停止/破棄します。
他UserForm で発行しているタイマーには影響しません。
True : 他UserForm が発行したタイマーも含めて、全てのタイマーを一括で停止/破棄します。
親UserForm の終了時に、 安全策として、子UserForm 発行のタイマー分も一緒に停止
/破棄しておくといった使い方で利用します。
※ この DestroyAll メソッドによって、全て (自UserForm/他UserForm 含めて) のタイマーが破棄された
(稼働中タイマーが全く無い) 場合には、TimerModule にある colClsTimer コレクションオブジェ
クト も合わせて破棄 (Nothing の設定) されます。
ユーザーサイドでは、Destroy / DestroyAll メソッド の実行を確実に行っておけば、TimerModule に
ある colClsTimer コレクションオブジェクト に意識を払う必要はありません。
【 プロパティ 】 object .Count ( [ AllTimer ] ) [ = Long ] Ver 3.0 〜
登録されている （稼働中の） タイマーの数を返します。
値の取得のみ可能です。
( AllTimer )
True または False を指定します。 省略すると False と見做します。
( 値の取得 )
AllTimer に指定した値によって、下記の値を返します。
True : 全て ( 他の UserForm で発行したものを含む ) の稼働中のタイマーの数を返します。
False or 省略 : 自UserForm で発行した稼働中のタイマーの数を返します。
【 イベント 】 Private Sub object_Tick ( ByVal TimerID As Long )
タイマー発行時に指定された時間間隔で発生します。複数のタイマーを処理している場合は、TimerID の
内容によって、対応するタイマー処理へ振り分けて下さい。
( TimerID )
Create メソッドで指定した TimerID の値が返ります。
『注意』 （ このページ先頭の赤色の注意事項も熟読の事 ）
このイベントルーチン内で行なう処理では 【実行時エラー】 が発生しないように充分に留意して下さい。
検索やチェック処理などでは、実行時エラーの発生が避けられないものもあります。そのような場合には、
[ On Error Resume Next ] などのエラー処理を確実に施すように留意して下さい
サンプルコードのように、UserForm の時計ラベル表示のみといった単純な処理ならばタイマーをそのまま
継続していても構いませんが、
・ 多少時間を要する （タイマー間隔を超えるような）
・ エラーが発生する可能性がある
・ ブック・シートへの操作（セルへの書き出し 等） を行なう
といった処理の場合には、このイベントルーチンに入った際に
一端 『 Destroy メソッド で タイマー停止』
してから処理を行ない、イベントルーチンを抜ける際に
再度 『 Create メソッド で タイマー発行』
するようにしてください。
====================================================================
タイマーコントロール クラス の利用例
====================================================================
RaiseEvent ステートメント 並びに AddressOf 演算子 を使用していますので、このクラスは
『Excel2000 以上』でのみ利用できます （Excel97 では利用できません）。
このクラスは UserForm モジュールでのみ利用できます。
サンプルブック に収録してある テストマクロ と ほぼ同じものですが、サンプルブックの方がエラー処理を
しっかり行なっていますので、実際にはサンプルブックの方のマクロを利用してください。
下記のコードは、UserForm上にデジタル時計を表示するサンプルです。複数のタイマー
が個別に動作している事を確認できるように、「１秒間隔」と「３秒間隔」で現在時刻をラベル
とセルに表示します。また、「１０秒後」に自動的（ユーザー操作中でも）にMsgBox を表示し
ます。
UserForm に、コマンドボタンを５つ（CommandButton1〜5）、ラベルを２つ（Label1〜2）、
テキストボックスを適当（ユーザー入力操作中でのデモの為）に配置して下記コードをコピー
して下さい。更に後述の「タイマーコントロールのソースコード（ TimerModule, clsTimer ）」
を標準モジュール/クラスモジュールに追加します。
ユーザーフォーム表示後に、ボタン１〜４で下記のデモが行なえます。
・ボタン１をクリックすると１秒間隔のタイマーが起動し、１秒間隔で現在時刻が
Label1 に リアルタイムで表示されます（普通にデジタル時計）。
・ボタン２をクリックすると３秒間隔で現在時刻が Label2 に表示されます。
・ボタン３をクリックすると１０秒経過のタイミングで自動的に MsgBox が表示さ
れます（これは、その都度タイマーを停止してますので、繰り返し試す場合は
再度ボタン３をクリックします）。
・ボタン４をクリックすると１秒間隔で現在時刻が Ａ１セル に表示されます。
４つのタイマーは平行して起動させる事が可能です。タイマーを停止する場合はボタン５を
クリックします。一度停止させた後、再度起動する事も可能です。
======= サンプルフォーム UserForm1 =======
Private WithEvents Timer1 As clsTimer ' タイマーのクラスオブジェクト
Private Sub UserForm_Initialize ( )
Set Timer1 = New clsTimer ' インスタンスの生成
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
' 後始末
Timer1.DestroyAll
Set Timer1 = Nothing
End Sub
Private Sub Timer1_Tick (ByVal TimerID As Long) ' タイマーイベント
Select Case TimerID
Case 1
Label1.Caption = Format(Now, "h:mm:ss")
Case 2
Label2.Caption = Format(Now, "h:mm:ss")
Case 3
Timer1.Destroy 3
MsgBox "１０秒経過しました"
Case 4
'セル書き出しの場合、安全の為に一端タイマーを停止する
Timer1.Destroy 4
Worksheets("Sheet1").Range("A1").Value = Format(Now, "h:mm:ss")
Timer1.Create Me, 4, 1
End Select
End Sub
Private Sub CommandButton1_Click ( )
'１秒間隔タイマー(Label 表示)を１番で登録/開始
Timer1.Create Me, 1, 1
End Sub
Private Sub CommandButton2_Click ( )
'３秒間隔タイマー(Label 表示)を２番で登録/開始
Timer1.Create Me, 2, 3
End Sub
Private Sub CommandButton3_Click ( )
'１０秒間隔タイマー(MsgBox )を３番で登録/開始
Timer1.Create Me, 3, 10
End Sub
Private Sub CommandButton4_Click ( )
'１秒間隔タイマー(セル書き出し)を４番で登録/開始
Timer1.Create Me, 4, 1
End Sub
Private Sub CommandButton5_Click ( )
'タイマー停止（４つとも）
Timer1.Destroy 1
Timer1.Destroy 2
Timer1.Destroy 3
Timer1.Destroy 4
'または
' Timer1.DestroyAll
End Sub
========================================================================
タイマーコントロール クラス のソースコード
(下記マクロは x64 対応前の Ver 2.0 です。x64 対応の Ver 3.0 はサンプルブックを参照して下さい。)
========================================================================
RaiseEvent ステートメント 並びに AddressOf 演算子 を使用していますので、このクラスは
『Excel2000 以上』でのみ利用できます （Excel97 では利用できません）。
このクラス は UserForm モジュールでのみ利用できます。
このクラスを利用する場合は、下記の標準モジュール『 TimerModule 』とクラスモジュー
ル『 clsTimer 』の２つをコピーして下さい（モジュールの名前は変えないで下さい）。なお、
利用に際し、両モジュールとも内容は一切変更する必要はありません。
複数のUserForm から利用する場合であっても、『TimerModule 』はひとつのみです。ひと
つの『TimerModule 』で全てのUserForm からのタイマーを管理/処理します。
恐れ入りますが、「VBE でモジュールの追加が判らない」 「クラスモジュールとは何ですか？」 といったレベル
の方はトラブルの元ですから絶対に利用しないで下さい。VBA の知識を十二分に習得し、ここで掲載している
コードを独力で読解できるようになってからにして下さい。
このマクロは x64 対応前の Ver 2.0 です。
======= 標準モジュール 【 TimerModule 】 =======
'タイマー情報
' Key: "TA" & Hwnd & "@" & ID, Data: clsTimerオブジェクト
' Key: "TB" & Hwnd & "@" & ID, Data: Hwnd & "@" & ID
Public colClsTimer As Collection
Public Sub TimerEvent (ByVal Hwnd As Long, ByVal uMsg As Long, _
ByVal IDEvent As Long, ByVal dwTime As Long)
Dim i As Integer
Dim objTimer As clsTimer
If (colClsTimer Is Nothing) Then
Exit Sub 'タイマー登録情報なし
End If
On Error Resume Next
Set objTimer = Nothing
Set objTimer = colClsTimer.Item ("TA" & CStr(Hwnd) & "@" & CStr(IDEvent))
On Error GoTo 0
If (objTimer Is Nothing) Then
'指定IDのタイマー未登録
Else
objTimer.RaiseTick IDEvent 'タイマーイベント励起
End If
Set objTimer = Nothing
End Sub
このマクロは x64 対応前の Ver 2.0 です。
======= クラスモジュール 【 clsTimer 】 =======
Private Declare Function SetTimer Lib "user32" _
(ByVal Hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Sub KillTimer Lib "user32" _
(ByVal Hwnd As Long, ByVal nIDEvent As Long)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Event Tick(ByVal TimerID As Long) 'タイマーイベント
Private MyHwnd As Long '呼び元 UserForm のHwnd
'【初期化処理】
Private Sub Class_Initialize ( )
MyHwnd = -1 'Hwndの未設定状態
End Sub
'【終了処理】
Private Sub Class_Terminate ( )
'クラス解放時に停止忘れのタイマーが残っていないかを確認し、
'残っていれば停止する(自Hwndのみ)。
Me.DestroyAll
End Sub
'【タイマーイベント励起】
Public Sub RaiseTick(ByVal TimerID As Long)
RaiseEvent Tick(TimerID)
End Sub
'【タイマーの登録＆スタート】
' Caller : 呼び元のUserForm
' TimerID : 任意の数値
' Interval: タイマー間隔を秒単位で指定
Public Sub Create(ByVal Caller As MSForms.UserForm, _
ByVal TimerID As Long, ByVal Interval As Long)
Dim strKey As String
If (Caller Is Nothing) Or _
(TimerID <= 0) Or (Interval <= 0) Then
Exit Sub
End If
If (MyHwnd <= 0) Then
'初回なので、呼び元UserFormのHwndを取得＆保存
MyHwnd = FindWindow("ThunderDFrame", Caller.Caption)
End If
'TimerID 重複/２重起動に備えて、そのTimerIDのタイマーを停止
'停止処理の中でコレクション情報も削除される
Me.Destroy TimerID
'タイマーが全く未起動の場合はコレクションのインスタンスも未生成
If (TimerModule.colClsTimer Is Nothing) Then
Set TimerModule.colClsTimer = New Collection
End If
'タイマー管理情報の登録
strKey = CStr(MyHwnd) & "@" & CStr(TimerID)
With TimerModule.colClsTimer
.Add Item:=Me, Key:="TA" & strKey
.Add Item:=strKey, Key:="TB" & strKey
End With
'タイマー起動
SetTimer MyHwnd, TimerID, (Interval * 1000), _
AddressOf TimerModule.TimerEvent
End Sub
'【タイマーの停止】
Public Sub Destroy(ByVal TimerID As Long)
Dim objTimer As Object
Dim strKey As String
If (MyHwnd <= 0) Or (TimerID <= 0) Then
Exit Sub
End If
If (TimerModule.colClsTimer Is Nothing) Then
Exit Sub 'タイマー登録なし
End If
strKey = CStr(MyHwnd) & "@" & CStr(TimerID)
On Error Resume Next
Set objTimer = Nothing
Set objTimer = TimerModule.colClsTimer.Item("TA" & strKey)
On Error GoTo 0
If (objTimer Is Nothing) Then
Exit Sub '指定IDのタイマー未登録
End If
'指定タイマーの停止
KillTimer MyHwnd, TimerID
'タイマー管理情報の削除
With TimerModule.colClsTimer
.Remove "TA" & strKey
.Remove "TB" & strKey
End With
If (TimerModule.colClsTimer.Count = 0) Then
'タイマー全解放により管理情報コレクションも解放
Set TimerModule.colClsTimer = Nothing
End If
End Sub
'【全タイマーの停止(自Hwndのみ)】
Public Sub DestroyAll()
Dim vntItem As Variant
Dim strHwnd As String
Dim lngTimerID() As Long
Dim i As Integer
If (TimerModule.colClsTimer Is Nothing) Then
Exit Sub
ElseIf (TimerModule.colClsTimer.Count = 0) Then
Set TimerModule.colClsTimer = Nothing
Exit Sub
End If
If (MyHwnd <= 0) Then
Exit Sub
End If
strHwnd = CStr(MyHwnd) & "@"
ReDim lngTimerID(1 To TimerModule.colClsTimer.Count)
i = 0
For Each vntItem In TimerModule.colClsTimer
'[TA:Object(clsTimer) , TB:String]
If (VarType(vntItem) = vbString) Then
If (Left(vntItem, Len(strHwnd)) = strHwnd) Then
i = i + 1
lngTimerID(i) = Val(Mid(vntItem, Len(strHwnd) + 1))
End If
End If
Next vntItem
For i = 1 To UBound(lngTimerID)
If (lngTimerID(i) > 0) Then
Me.Destroy lngTimerID(i)
End If
Next i
'タイマー全解放時の「管理情報コレクション解放」はDestroy内で行なわれる
End Sub
[ この場所へのリンク ]
====================================================================
[ clsDec7Seg ] クラス リファレンス / 利用例 (2012/ 3/18 Ver 3.1 で収録)
====================================================================
下記で[ object ]の部分には、clsDec7Seg クラスを定義したオブジェクト変数を記述します。
【 定 義 】 [ ７ セグメント数字 ] を使用するUserForm モジュールの宣言セクション（モジュールの先頭）で、下記の
ように定義します。
Private object As clsDec7Seg
( object )
任意の名前を指定して下さい。
クラスの実行に先立ち （Initialize イベント等 ）、下記のようにしてクラスのインスタンスを作成します。
Set object = New clsDec7Seg
UserForm を閉じる前 （QueryClose イベント等 ） には、下記のようにしてクラスインスタンスの解放を
行ってください。
Set object = Nothing
または Erase object （object が 配列 の場合）
１数字分（７個のラベル）で １ クラスオブジェクト を構成します。
上記の デジタル時計の場合には ６個の クラスオブジェクトになります。
各ラベルのコントロール名は [ プリフィックス + セグメント番号 ] とします。
セグメント番号の並びは 左図 の通りです。
（例） lblSeg_1 , lblSeg_2 , ……
lblSeg_11 , lblSeg_12 , ……
７ セグメントに使用するラベルコントロール群は、サンプルブックの UserForm4 から コピーして利用
してください。
【 メソッド 】 object .Rgst Owner , Prefix
７ 個のラベルを １数字分として登録します。
( Owner )
７セグメント数字を組み込む UserForm を指定します。実際には 「Me キーワード」 を指定します。
( Prefix )
７ セグメント数字を構成する [ ７個の ラベルコントロール ] の プリフィックス名を文字列で指定します。
Rgst メソッド内で [ プリフィックス + (1 〜 7) ] のコントロール名のラベルコントロールを登録します。
コントロールが ７個 揃って存在していない場合には Rgst メソッドは失敗し（実行時エラーにはなりません。
無視するだけです）、Value プロパティ に値を指定しても反応しません。
【 プロパティ 】 object .Value Value [ = Integer ]
指定の 数字 を表すパターンで ７ セグメント の表示を切り替えます。
( Value )
表示する 数値 を指定します。
( 値の設定 )
0 〜 9 の値を指定します。
上記以外( -1 等 ) を指定すると、７セグメント全てを消灯します。
下記サンプル および clsDec7Seg クラス は、サンプルブックに収録されています。
このサンプルでは デジタル時計を実装しますので、一緒にタイマーコントロールクラス(clsTimer)
を使用します。
======= サンプルフォーム UserForm4 =======
Option Explicit
'タイマーコントロール用クラスオブジェクト
Private WithEvents Timer4 As clsTimer
Private DigitalClock(1 To 6) As clsDec7Seg
'７セグメントの表示更新
Private Sub DegitalClock_Change()
Dim strTime As String
Dim j As Integer
strTime = Format(Now, "hhmmss")
For j = 1 To 6
DigitalClock(j).Value = Val(Mid(strTime, j, 1))
Next j
End Sub
Private Sub UserForm_Initialize()
Set Timer4 = New clsTimer 'タイマーのインスタンスの生成
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Timer4.DestroyAll '引数省略(False)で自Form発行タイマーのみ全て破棄
Set Timer4 = Nothing
End Sub
Private Sub UserForm_Terminate()
Erase DigitalClock 'デジタル時計の破棄(グレー表示になる)
End Sub
Private Sub Timer4_Tick(ByVal TimerID As Long)
Select Case TimerID
Case 1
Call DegitalClock_Change
End Select
End Sub
Private Sub cmdStart_Click()
Dim j As Integer
For j = 1 To 6
Set DigitalClock(j) = New clsDec7Seg
'コントロール名： "lblSeg_XY" X(1-6, hhmmss) , Y(1-7, Segment)
'セグメント番号を除いたプリフィックスを渡す
DigitalClock(j).Rgst Me, "lblSeg_" & j
Next j
Call DegitalClock_Change
'１秒間隔タイマー(デジタル時計)を１番で登録
Timer4.Create Me, TimerID:=1, Interval:=1
End Sub
Private Sub cmdStop_Click()
Timer4.DestroyAll '引数省略(False)で自Form発行タイマーのみ全て破棄
Erase DigitalClock 'デジタル時計の破棄(グレー表示になる)
End Sub
======= ７セグメントクラス clsDec7Seg =======
Option Explicit
' ７セグメントのコントロール名： xxxxN xxxx:Prefix , N=1-7
' ７セグメントの配置
' --(1)--
' I I
' (6) (2)
' I I
' --(7)--
' I I
' (5) (3)
' I I
' --(4)--
'
Private lbl7Seg(1 To 7) As MSForms.Label
Private blnRgst As Boolean
Private blnSegState(0 To 9, 1 To 7) As Boolean
Private Const cstON As Long = &H8080FF '薄赤
Private Const cstOFF As Long = &H808080 'Gray
Private Sub Class_Initialize()
Const cstState As String = "1111110,0110000,1101101,1111001," & _
"0110011,1011011,1011111,1110000," & _
"1111111,1111011"
Dim vntStateWK As Variant
Dim j As Integer
Dim k As Integer
vntStateWK = Split(cstState, ",")
For j = 0 To 9
For k = 1 To 7
blnSegState(j, k) = CBool(Mid(vntStateWK(j), k, 1))
Next k
Next j
End Sub
Private Sub Class_Terminate()
If (blnRgst = True) Then
Me.Value = -1 '全セグメント消灯
End If
Erase lbl7Seg
End Sub
'７セグメント用ラベルコントロールは、
'名前の末尾１桁(1 - 7)を除いたプリフィックス名で指定する。
Public Sub Rgst(ByRef argOwner As MSForms.UserForm, ByVal argPrefix As String)
Dim j As Integer
Dim strWK As String
For j = 1 To 7
On Error Resume Next
strWK = ""
strWK = argOwner.Controls(argPrefix & j).Name
On Error GoTo 0
If (strWK = "") Then
Erase lbl7Seg
blnRgst = False
Exit Sub
End If
Set lbl7Seg(j) = argOwner.Controls(argPrefix & j)
Next j
blnRgst = True
Me.Value = -1 '全セグメント消灯
End Sub
Public Property Let Value(ByVal argValue As Integer)
Dim j As Integer
If (blnRgst = False) Then
Exit Property
End If
If (argValue < 0) Or (argValue > 9) Then
'[0-9]以外を渡された場合は全セグメント消灯
For j = 1 To 7
lbl7Seg(j).BackColor = cstOFF
Next j
Exit Property
End If
For j = 1 To 7
If (blnSegState(argValue, j) = True) Then
If (lbl7Seg(j).BackColor = cstON) Then
'そのまま
Else
lbl7Seg(j).BackColor = cstON
End If
Else
If (lbl7Seg(j).BackColor = cstOFF) Then
'そのまま
Else
lbl7Seg(j).BackColor = cstOFF
End If
End If
Next j
End Property
 |
 |
|
|
|
||
| 角田 桂一 Mail:addinbox@h4.dion.ne.jp CopyRight(C) 2005 Allrights Reserved. | ||
