为一个网友写的真正的精确到毫秒级的动态秒表。顺便散分!

东方之珠 2007-12-25 05:36:34
为一个网友写的真正的精确到毫秒级的动态秒表。这个网友发贴子提问,只精确到了秒,我觉得动得不够快,所以改进了一下,动得很快,并修改了这个网友的错误。

转载请标明出处。 VB演示窗体下载(源码):http://download.csdn.net/source/316696

Option Explicit

Dim x As Long
Dim h As Long, m As Long, s As Long, ms As Long
Dim cjlh As Long, cjlm As Long, cjls As Long
Dim cjlms As String
Private Sub Form_Load()
'Form1.StartUpPosition = 2
Form1.Caption = "真正的动态秒表(小时:分:秒.毫秒)"
Command1.Caption = "开始[&S]"
Command2.Caption = "结束[&E]"
Label1.Alignment = 2 '居中对齐
Label1.Caption = "00:00:00.000"
Timer1.Interval = 10
Timer1.Enabled = False
Label1.BackColor = &H0&
Label1.ForeColor = &HFF00&
Label1.Font.Name = "Arial Rounded MT Bold"
Label1.Alignment = 2
x = 0
End Sub
Private Sub Command1_Click()
Timer1.Enabled = True
Label1.Font.Size = 24
End Sub
Private Sub Command2_Click()
Timer1.Enabled = False
Label1.Font.Size = 14
x = 0
Label1.Caption = "运行了" & IIf(Len(Trim(Str(h))) < 2, "0" & Trim(Str(h)), Trim(Str(h))) & "小时" & IIf(Len(Trim(Str(m))) < 2, "0" & Trim(Str(m)), Trim(Str(m))) & "分" & IIf(Len(Trim(Str(s))) < 2, "0" & Trim(Str(s)), Trim(Str(s))) & "秒" & cjlms & "毫秒"
Form1.Caption = Label1.Caption
End Sub
Private Sub Timer1_Timer() '每1秒钟触发100次
x = x + 10 '单位是毫秒
cjlh = Int(x / 3600000)
h = cjlh '取得小时
cjlm = Int(((x Mod 3600000) / 60000)) '关键在这里,用INT取整,不用INT的话,每30秒进1,有点奇怪
m = cjlm '取得分钟
cjls = Int(((x Mod 3600000) Mod 60000) / 1000)
s = cjls '取得秒种
ms = (((x Mod 3600000) Mod 60000) Mod 1000)
If Len(Trim(Str(ms))) = 2 Then
cjlms = "0" & Trim(Str(ms))
End If
If Len(Trim(Str(ms))) >= 3 Then
cjlms = Trim(Str(ms))
End If
cjlms = Left(cjlms, 2) & Trim(Str(Int(Rnd * 9)))
Label1.Caption = IIf(Len(Trim(Str(h))) < 2, "0" & Trim(Str(h)), Trim(Str(h))) + ":" + IIf(Len(Trim(Str(m))) < 2, "0" & Trim(Str(m)), Trim(Str(m))) + ":" + IIf(Len(Trim(Str(s))) < 2, "0" & Trim(Str(s)), Trim(Str(s))) + "." + cjlms
End Sub




...全文
822 点赞 收藏 31
写回复
31 条回复
切换为时间正序
请发表友善的回复…
发表回复
做了下测试
Private Sub Command1_Click()
Dim i As Long, t As Double, t2 As Double, x As Boolean
Dim ts(19) As Double
While i < 20
x = True
t = Timer
Do While x
t2 = Timer
If t2 > t Then
ts(i) = t2 - t
t = t2
x = False
End If
Loop
i = i + 1
Wend
For i = 0 To 19
Debug.Print ts(i) * 1000000
Next
End Sub


输出结果

15999.9999959837
16000.0000032596
14999.9999994179
16000.0000032596
14999.9999994179
15999.9999959837
16000.0000032596
14999.9999994179
15999.9999959837
16000.0000032596
14999.9999994179
16000.0000032596
14999.9999994179
15999.9999959837
16000.0000032596
14999.9999994179
15999.9999959837
16000.0000032596
14999.9999994179
16000.0000032596


Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub Command1_Click()
Dim i As Long, t As Double, t2 As Double, x As Boolean
While i < 20
x = True
t = GetTickCount
Do While x
t2 = GetTickCount
If t2 > t Then
Debug.Print t
t = t2
x = False
End If
Loop
i = i + 1
Wend
End Sub


输出结果

16000
15000
16000
16000
15000
16000
15000
16000
16000
15000
16000
16000
15000
16000
15000
16000
16000
15000
16000
16000

'然后再试试老马提供的2个函数 QueryPerformanceFrequency,QueryPerformanceCounter

Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type

Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long

Private Sub Command1_Click()
Dim i As Long, t As LARGE_INTEGER, t2 As LARGE_INTEGER, x As Boolean, tc As LARGE_INTEGER
Dim ts(19) As Double
QueryPerformanceFrequency tc
Debug.Print tc.highpart, tc.lowpart
While i < 20
QueryPerformanceCounter t
x = True
Do While x
QueryPerformanceCounter t2
If (t2.lowpart <> t.lowpart) Then
ts(i) = (t2.lowpart - t.lowpart)
t = t2
x = False
End If
Loop
i = i + 1
Wend
For i = 0 To 19
Debug.Print ts(i) / tc.lowpart * 1000000 '转化成微秒单位
Next
End Sub


输出结果

0 3579545
2.51428603356013
1.67619068904009
1.9555558038801
1.67619068904009
1.9555558038801
1.67619068904009
1.9555558038801
1.9555558038801
1.67619068904009
1.9555558038801
1.9555558038801
1.67619068904009
1.67619068904009
1.67619068904009
1.9555558038801
1.67619068904009
1.9555558038801
1.67619068904009
1.9555558038801
1.67619068904009

这里的结果表示 每次递增的时间 单位都是微妙
回复
东方之珠 2007-12-29
感谢各位朋友的大力支持。
我已经找到原因了,我21楼那个代码,在高速频繁运行的代码中不能用VB函数IIF、LEN、TRIM、STR,会造成内存问题。这就是为什么,我21楼那个代码只能在VB开发环境下运行,而编译成EXE运行时只要一按“开始计时”立即崩溃,没有一次成功。结贴,谢谢大家!
回复
zzyong00 2007-12-29
'Example Name:Performance Counter
Private Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Sub Form_Load()
'KPD-Team 2001
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
Dim T As Long, liFrequency As LARGE_INTEGER, liStart As LARGE_INTEGER, liStop As LARGE_INTEGER
Dim cuFrequency As Currency, cuStart As Currency, cuStop As Currency
'Retrieve the frequency of the performance counter
If QueryPerformanceFrequency(liFrequency) = 0 Then
MsgBox "Your hardware doesn't support a high-resolution performance counter!", vbInformation
Else
'convert the large integer to currency
cuFrequency = LargeIntToCurrency(liFrequency)
'retrieve tick count
QueryPerformanceCounter liStart
'do something
For T = 0 To 100000
DoEvents
Next T
'retrieve tick count
QueryPerformanceCounter liStop
'convert large integers to currency's
cuStart = LargeIntToCurrency(liStart)
cuStop = LargeIntToCurrency(liStop)
'calculate how many seconds passed, and show the result
MsgBox "Time: " + CStr((cuStop - cuStart) / cuFrequency) + " seconds"
End If
End Sub
Private Function LargeIntToCurrency(liInput As LARGE_INTEGER) As Currency
'copy 8 bytes from the large integer to an ampty currency
CopyMemory LargeIntToCurrency, liInput, LenB(liInput)
'adjust it
LargeIntToCurrency = LargeIntToCurrency * 10000
End Function

foxAPI例程
回复
flyingscv 2007-12-29
印象中timer只能精确到每秒18.2次,也就是硬件的时钟中断次数
回复
KiteGirl 2007-12-29
写一个精确到毫秒的秒表用这么麻烦吗?秒表只要记时精确到毫秒就可以了,追求显示精确有什么意义呢?
下面这个秒表直接用Timer函数写的,精确到1/10000秒,连清零过程产生的误差都会被体现出来。

Private priOnTimer As Double
Private priAddTimer As Double

Private Sub Command1_Click()
If Timer1.Enabled Then
priAddTimer = priAddTimer + Abs(priOnTimer - Timer)
End If
Timer1.Enabled = Not Timer1.Enabled
priOnTimer = Timer
ShowTimer
End Sub

Private Sub Command2_Click()
priAddTimer = 0
priOnTimer = Timer
ShowTimer
End Sub

Private Sub Timer1_Timer()
ShowTimer
End Sub

Sub ShowTimer()
Text1.Text = TimeStr(Abs(priOnTimer - Timer) + priAddTimer)
End Sub

Function TimeStr(ByVal pTimer As Double) As String
Dim tH As Long
Dim tM As Long
Dim tS As Long
Dim tMS As Long
Dim tAT As Double
tAT = pTimer * 10000
tMS = tAT Mod 10000
tS = tAT \ 10000 Mod 100
tM = tAT \ 600000 Mod 100
tH = tAT \ 36000000 Mod 100
TimeStr = Format(tH, "00") & ":" & Format(tM, "00") & ":" & Format(tS, "00") & ":" & Format(tMS, "0000")
End Function

回复
东方之珠 2007-12-27
用多媒体计数器做的真正的动态秒表。演示窗体下载地址 http://download.csdn.net/source/318216
回复
东方之珠 2007-12-27
重新发布,原来的作废。

是我错了,错了就是错了,既然要做就把它做好,否则对不起这位网友。
最后选择了多媒体计数器!运行一分钟误差十几毫秒,调用自定义的函数TimeLabel转换时间,付出了代价,花了些时间。
理论上,高精度频率计数器最精确,毕竟API QueryPerformanceFrequency,QueryPerformanceCounter可以精确到微秒级;但是,它要认计算机,跟什么样的主板和操作系统有关,通用性不好,同时,它还会受外界影响,比如:拖动窗体计数器会暂停响应;适合短时间计时。
实际上,多媒体计数器最适用,适合长时间计时,最适合计算机软件运行计时;同时,API函数timeSetEvent内部实现多线程,不会受外界影响。
------------------------------------------------------------------------------------------------------
遗憾的是,这几个VB代码只能在VB开发环境下运行,编译成EXE运行会崩溃,我还没来得及找是什么原因,各位朋友有兴趣的话帮我分析一下。
------------------------------------------------------------------------------------------------------

'标准模块:Module1.bas
Option Explicit

Public Declare Function timeSetEvent Lib "winmm.dll" (ByVal uDelay As Long, ByVal uResolution As Long, ByVal lpFunction As Long, ByVal dwUser As Long, ByVal uFlags As Long) As Long
Public Declare Function timeKillEvent Lib "winmm.dll" (ByVal uID As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long

Public MediaCount As Single '累加量
Public TimeID As Long '返回多媒体记时器对象标识
Public StartTime As Long '开始时间
Public EndTime As Long '结束时间
Public h As Long, m As Long, s As Long, ms As Long
Public cjlms As String

'API函数timeSetEvent使用的回调过程
Public Sub TimeSEProc(ByVal uID As Long, ByVal uMsg As Long, ByVal dwUser As Long, ByVal dw1 As Long, ByVal dw2 As Long)
Form1.Label1.Caption = TimeLabel(CLng(MediaCount * 1000))
MediaCount = MediaCount + 0.001
End Sub

Public Function TimeLabel(msTime As Long) As String '将毫秒时间转换成时间标签:时:分:秒.毫秒
Dim x As Long
x = msTime '单位毫秒
h = Int(x / 3600000) '计算小时
m = Int((x Mod 3600000) / 60000) '计算分钟
If m >= 60 Then
m = 0: h = h + 1
End If
s = Int((x Mod 3600000) Mod 60000) / 1000 '计算秒钟
If s >= 60 Then
s = 0: m = m + 1
End If
ms = ((x Mod 3600000) Mod 60000) Mod 1000 '计算毫秒数
If Len(Trim(Str(ms))) = 1 Then
cjlms = "00" & Trim(Str(ms))
End If
If Len(Trim(Str(ms))) = 2 Then
cjlms = "0" & Trim(Str(ms))
End If
If Len(Trim(Str(ms))) > 2 Then
cjlms = Trim(Str(ms))
End If
TimeLabel = IIf(Len(Trim(Str(h))) < 2, "0" & Trim(Str(h)), Trim(Str(h))) & ":" & IIf(Len(Trim(Str(m))) < 2, "0" & Trim(Str(m)), Trim(Str(m))) & ":" & IIf(Len(Trim(Str(s))) < 2, "0" & Trim(Str(s)), Trim(Str(s))) & "." & cjlms

End Function


'Form1的窗体模块
Option Explicit

Private Sub Form_Load()
Form1.Caption = "真正的动态秒表(小时:分:秒.毫秒)"
Form1.BackColor = &HFF8080
Command1.Caption = "开始计时[&S]"
Command2.Caption = "停止计时[&E]"
Command1.Enabled = True
Command2.Enabled = False
Label1.Alignment = 2 '居中对齐
Label1.Caption = "00:00:00.000"
Label2.Caption = "开始时间:" & "00:00:00.000"
Label3.Caption = "结束时间:" & "00:00:00.000"
Label4.Caption = "运行时间:" & "00:00:00.000"
Label1.BackColor = &H0&
Label1.ForeColor = &HFF00&
Label1.Font.Name = "Arial Rounded MT Bold"
Label1.Font.Size = 24
Label2.ForeColor = &HFFFF00
Label3.ForeColor = &HFFFF00
Label4.ForeColor = &HFFFF00
End Sub
Private Sub Command1_Click()
Command1.Enabled = False
Command2.Enabled = True
Label3.Caption = "结束时间:" & "00:00:00.000"
Label4.Caption = "运行时间:" & "00:00:00.000"
MediaCount = 0
StartTime = GetTickCount '记住开始时间
Label2.Caption = "开始时间:" & TimeLabel(StartTime)
TimeID = timeSetEvent(1, 0, AddressOf TimeSEProc, 1, 1) '间隔时间为1毫秒
End Sub
Private Sub Command2_Click()
Command2.Enabled = False
Command1.Enabled = True
Call timeKillEvent(TimeID)
EndTime = GetTickCount '记住结束时间
Label3.Caption = "结束时间:" & TimeLabel(EndTime)
Label4.Caption = "运行时间:" & TimeLabel(GetTickCount - StartTime)
Form1.Caption = "运行了" & IIf(Len(Trim(Str(h))) < 2, "0" & Trim(Str(h)), Trim(Str(h))) & "小时" & IIf(Len(Trim(Str(m))) < 2, "0" & Trim(Str(m)), Trim(Str(m))) & "分" & IIf(Len(Trim(Str(s))) < 2, "0" & Trim(Str(s)), Trim(Str(s))) & "秒" & cjlms & "毫秒"
End Sub

Private Sub Form_Unload(Cancel As Integer)
Unload Me
End Sub

回复
我用过TIMER控件做实事控制,这个控件非常的不准,当其他的进程阻塞了,定时精度有时秒级都达不到.
我认为在VB中要精确定时还得靠API。
回复
思路搞通了就OK了

今天好冷,早点睡.......

明天就有事干了.....新的控制器与马达发过来,我要写控制程序了.....
回复
ZW_LM 2007-12-27
个人认为还是使用Gettickcount可能比定时器更精确些。
回复
东方之珠 2007-12-27
老马这么一说,我有兴趣了!
回复
QueryPerformanceFrequency,QueryPerformanceCounter不是要认机器....

用法没对头

先用QueryPerformanceFrequency得到一秒内本机可以完成的计数器值,保存;

以后计数时,就两次调用QueryPerformanceCounter,其差就是两次调用间计数器所完成的计数值;

再把此值除以QueryPerformanceFrequency得到的值,就可以得到经过的时间.....

这个可以达到微秒级~~
回复
chouchou_0723 2007-12-26
既然这么强,那就施舍点分吧
回复
cangwu_lee 2007-12-26
這個題目,用 TIMER 控件,本來就不對了。
回复
a97191 2007-12-26
接分
回复
东方之珠 2007-12-26
楼上说得没错,问题是很大。原因是用INT取整后,误差太大。
但也不是像你说的timer控件不能用来计时,Timer事件定时触发是很准的,只是我的算错了,看来要把误差加上,缩小些差距。
回复
kuhe 2007-12-26
楼主的代码可能是在P3的机器上写的,到了更高级的机器上水土不服。
使用Timer属性的话可以定义个模块级的Single型m_Start,在计时开始时给m_Start赋值:
m_Start=Timer
然后在Timer控件引发的事件中用Timer-m_Start即可以计算出经历的秒数,精度能够达到10ms级。
回复
windlysnowly 2007-12-26
up 学习
回复
kuhe 2007-12-26
我以前测试过Timer控件每秒内能够触发的最大次数,在P3机器上可以达到100次;但在P4机器上却只有64次。这是由硬件决定的。下面是测量Timer控件每秒内能够触发的最大次数的代码,你们可以试试,开始的时候把Timer的Inteval属性设成1(ms):
Option Explicit

Private m_Count As Single, m_Time(99) As Single

Option Explicit

Private m_Count As Single, m_Time(99) As Single

Private Sub Command1_Click()
m_Count = 0
Timer1.Enabled = True
Command1.Enabled = False
End Sub

Private Sub Timer1_Timer()
m_Time(m_Count) = Timer
If m_Count = 99 Then
Timer1.Enabled = False
Command1.Enabled = True
Text1.Text = "每秒最多触发" & Format$(100 / (m_Time(99) - m_Time(0)), "0") & "次"
Else
m_Count = m_Count + 1
End If
End Sub

至于计时部分,由于Timer两次触发间的间隔在10ms量级,也就没必要使用QueryPerformanceCounter这样的高精度计时器,使用GetTickCount或timeGetTime即可,事实上Timer两次触发间的间隔正好也是后两个API所能分辨的最小间隔,这是完全匹配的。
当然要是偶的话直接用VB的Timer属性,Timer属性能分辨的最小间隔和后两个函数完全一样,但代码可以写的非常简单。
回复
不算啥 我也经常这样`
回复
发动态
发帖子
VB基础类
创建于2007-09-28

7451

社区成员

VB 基础类
申请成为版主
社区公告
暂无公告