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

东方之珠 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




...全文
1023 31 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
31 条回复
切换为时间正序
请发表友善的回复…
发表回复
砸死牛顿的苹果 2007-12-29
  • 打赏
  • 举报
 回复
做了下测试
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

laijianyong_dingling 2007-12-27
  • 打赏
  • 举报
 回复
我用过TIMER控件做实事控制，这个控件非常的不准，当其他的进程阻塞了，定时精度有时秒级都达不到.
我认为在VB中要精确定时还得靠API。
嗷嗷叫的老马 2007-12-27
  • 打赏
  • 举报
 回复
思路搞通了就OK了

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

明天就有事干了.....新的控制器与马达发过来,我要写控制程序了.....
ZW_LM 2007-12-27
  • 打赏
  • 举报
 回复
个人认为还是使用Gettickcount可能比定时器更精确些。
东方之珠 2007-12-27
  • 打赏
  • 举报
 回复
老马这么一说，我有兴趣了！
嗷嗷叫的老马 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属性能分辨的最小间隔和后两个函数完全一样，但代码可以写的非常简单。
砸死牛顿的苹果 2007-12-26
  • 打赏
  • 举报
 回复
不算啥 我也经常这样`
加载更多回复（11）
基于51单片机(普中开发板)的四位数码管秒表设计
说明 今天学校布置的课后作业，利用51单片机做一个秒表，本来是做了个8位数码管的秒表，但后来想了下秒表计时一般都不会用到以小时为单位，就把小时的部分以及毫秒的部分去掉了，就留下了分钟跟秒。 每个开发板的电路连接不一定是一样的，我所使用这块开发板是普中科技的，连接数码管的位选是接了一个138译码器的，如果是购买的普中科技的开发板可以直接复制程序就能使用，如果开发板的数码管的位选是接了锁存器的，那么就...
两位动态数码管电子秒表c语言,清翔电子51单片机6课动态显示数码管作业秒表...
单片机数码管电子钟单片机数码管电子钟单片机数码管电子钟单片机数码管电子钟单片机数码管电子钟单片机数码管电子钟单片机数码管电子钟单片机数码管电子钟单片机数码管电子钟 相关下载链接：//download.在对单片机编程以实现数码管静态显示数字之前，我们先来了解一下数码管的结构以及一些常识，对于数码管，有称八段数码管的，也有称七段数码管的，其实无非就是多在一个小数点h,如上图所示，我们就...博文来自...
我在CSDN参与的3000个帖子
 今日偶然翻到，感慨万千 1：申述：版主，是否扣了我的专家分？ 2：100分急求，随机输出十个小写字母，但是，要求这十个字母不相同 3：求Sn=a+aa+aaa+…+aaa…a（n个a）之值 4：数组题 望高手帮忙！ 5：呵呵，来推荐一下我的网站，本站提供大量当今流行的免费的音乐和免费电影，常用软件、游戏、精美图库下载,希望对网友有帮助!顺便散分! 6：VBA请教怎
TowardsDataScience 博客中文翻译 2016~2018（三百二十二）
有点令人惊讶的是，在所有机器学习的热门词汇中，我们很少听到一个短语将统计学习、信息论和自然哲学的一些核心概念融合成一个三个词的组合。此外，它不仅仅是一个为机器学习(ML)博士和理论家准备的晦涩而学究式的短语。对于任何有兴趣探索的人来说，它有一个精确和容易理解的含义，并且对于 ML 和数据科学的实践者来说，它有一个实际的回报。我说的是最小描述长度。你可能会想这到底是什么…让我们把这些层剥开，看看它有多有用…在深度学习的背景下，复杂性最好理解为复杂系统。系统是以某种方式相互作用的代理人的集合体。
服务器工作站显示器,HP Z25n超窄边框显示器【深度测评】
本文转自ChiphellHP Z25n超窄边框显示器深度测评先简单介绍一下：以n结尾的型号有Z24n、Z25n和Z27n三款。Z24n为1920×1200分辨率，长宽比16：10，8-bit面板，99% sRGB色域，响应时间8毫秒；Z25n则是2560×1440(2K)IPS屏幕，同样是8-bit面板，99% sRGB色域，响应时间比较长，达到了14毫秒，支持画中画和双画面显示功能；Z27n也使...
VB基础类

7,785

社区成员

197,585

社区内容

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今

加载中

查看更多榜单
社区公告
暂无公告

试试用AI创作助手写篇文章吧

+ 用AI写文章