システムの時刻を利用しながら800ミリ秒毎のイベント発生

質問

現在For～Next文とSleep(700)を使用し、
イベントの処理時間を100ミリ秒と換算し、
2台のPCで同じコードを適用させ、
約800ミリ秒ごとにイベントを発生させております。
しかし、処理コード中にIf文やFor文も多数使用しているため、
取得条件の違いや、システムの負荷（？）、PCの性能（？）より遅延が発生していたり、
2台のPC間で一時間当たりの取得情報の量に違いがあることがわかりました。
2台のPCはNTPによる時刻同期により時刻のズレはないものとします。
はたして、システムから時刻を取得しつつ、
正確な800ミリ秒ごとのイベントを発生させる方法はあるのでしょうか。
面倒くさい質問で申し訳ありませんが、どうかよろしくお願いいたします。
現在のコードを以下に記します。

Sub ●約800ミリ秒ごとイベント発生プログラム●()

Dim n As Long 'ループ用カウンタ
Dim data As String

For n = 1 To 26500

'ここから記録機能

Cells(n, "A") = Time

Sleep (700)
Calculate
DoEvents

'本当はここにイロイロなコードが入ります。
'ここに入るコードはスグに終わるときもあれば
'80ミリ秒くらいかかるときもあります。

Next

End Sub

回答No.3

noname#22222 · ベストアンサー

CommandButton1 を同時にクリックするコードは質問者に任せるとして・・・。
次のコードで正確に800ミリ秒単位でTextBox1に表示されます。
無限ループからの脱出はCommandButton2で・・・。
Excel、VBどちらでもOKです。

Option Explicit
Dim StopNow As Boolean

Private Sub CommandButton1_Click()
　　Dim S As Double ' Single でなく Double
　　Dim T As Double
　　Dim E As Double

　　S = Timer
　　T = S
　　E = S + 0.8
　　Do Until StopNow
　　　　Do Until S > E
　　　　　　S = Timer
　　　　　　DoEvents
　　　　Loop
　　　　UpdateText S
　　　　DoEvents
　　　　S = T + 0.8
　　　　E = S + 0.8
　　　　T = S
　　Loop
End Sub

Private Sub UpdateText(ByVal NowTime As Single)
　　TextBox1 = NowTime
End Sub

Private Sub CommandButton2_Click()
　　StopNow = True
End Sub

お礼

すみません、初心者であるため未だに実行できずにいます。
Private Sub ～の部分を別のモジュール（？）として
コピペしなければならないのかもしれないのでしょうね（よくわかりませんが）。
しかし、Loopを使用しているところがヒントになり、
自分のプログラムは期待通りの動作をさせることができるようになりました。

ご回答、ありがとうございました。

回答No.2

freemank

ＶＢだとTimerがあり問題ないのだけど、ＶＢＡなのですね！
時間があれば作ろうと思っていたので、作ってみました。
精度がどれほどのものかわかりませんが参考にしてみて下さい。
ボタン２つにテキスト３つの画面で作ってあります。

Dim miEnd As Integer
□□開始ボタンのクリック□□
Private Sub CommandButton1_Click()
'フラグの初期化
miEnd = False
'ループ開始
Call LoopSub
End Sub
□□終了ボタンクリック□□
Private Sub CommandButton2_Click()
'ループ終了指定
miEnd = True
End Sub
□□メインループ□□
Private Sub LoopSub()
Dim lSCount1 As Long
Dim lSCount2 As Long
Dim lECount1 As Long
Dim lECount2 As Long
Dim lMiri As Long
Dim sSTime As String
'指定ミリ秒の取得
lMiri = Val(TextBox1.Text)
'比較秒の取得
sSTime = Format(Now, "SS")
'初期化
lSCount1 = 0: lSCount2 = 0
lECount1 = 0: lECount2 = 37000
Do
'１秒にかかるカウント集計（毎秒数値を確認）
lSCount1 = lSCount1 + 1
If sSTime <> Format(Now, "SS") Then
sSTime = Format(Now, "SS")
lSCount2 = lSCount1
lSCount1 = 0
End If
'ミリ秒
lECount1 = lECount1 + 1
If lECount1 > lECount2 Then
lECount1 = 0
'指定ミリ秒に相当するカウント数を毎回算出
lECount2 = Int(lSCount2 / 1000 * lMiri)
□□イベントの記述□□
TextBox2.Text = lSCount2
TextBox3.Text = lECount2
□□□□□□□□□□□
End If
'ループ脱出処理（無限ループに注意）
DoEvents
If miEnd = True Then Exit Do
Loop
End Sub

処理中の誤差が少しでも少なくなるように
毎秒算出し、ヒットの度に再計算させてあります。
あと無限ループには充分ご注意ください。
長々とすんません…頑張ってください。

お礼

今回がはじめてのプログラミングであり、
VBAの基本がわかっていないことに気づきました。
Excelのツール→マクロ→Visual Basic Editor→
標準モジュールを追加→上記のコードをコピペ→
「□」の行の頭へコメント化のために「'」をつけたり、
Sub毎に標準モジュールに別々にコピペしたり、
試行錯誤しておりました（汗）
まだ出来ておりませんが、なんとかやってみせます。

ご回答、ありがとうございました。

回答No.1

noname#22222

Ｑ、800ミリ秒ごとのイベントを発生させるには？
Ａ、800ミリ秒ごとにイベントをコールする。

処理の実行速度に関わらず、800ミリ秒を足した時刻にイベントをコールすればと思います。

お礼

参考にさせていただきます。

ご回答、ありがとうございました。