向老马求教：高精度计时器问题！做过高精度计时器的朋友也可以进来指导！

东方之珠 2007-12-29 01:27:55
祝节日快乐！

改进了很多，但问题还是很多。
EXE运行文件及源码下载地址:http://download.csdn.net/source/320388

'===========================================================
'Form1的标准模块：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 Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Public Const TIME_PERIODIC = 1 ' program for continuous periodic event
Public Const TIME_ONESHOT = 0 ' program timer for single event
Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long

Public PerMSFreq As Currency '每毫秒震动的次数
Public HiCountStart As Single
Public MediaCount As Single '累加量
Public TimeID As Long '返回多媒体记时器对象标识
Public StartTime As Long '开始时间
Public EndTime As Long '结束时间

Public Type msTime '自定义时间类型
h As Long '时
m As Long '分
s As Long '秒
ms As Long '毫秒
End Type

Public MediaCounter As msTime, Hirpc As msTime '声明2个结构类型变量
'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((MediaCount * 1000)) '这里的计算付出了代价，显示到屏幕上稍微滞后。而且(MediaCount * 1000)的前面还不能加Clng转换，否则更滞后。
MediaCount = MediaCount + 0.001
End Sub

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

'Form1的窗体代码
'*****************************************************************************
'哈哈，经过测试，原来是这样：用鼠标一直按住窗体标题栏不放，高精度频率计数器会
'暂停计时，而多媒体计数器因API函数timeSetEvent内部实现独立线程而不受外界影响，
'作者：chenjl1031(东方之珠)
'*****************************************************************************
'Form1窗体上共需7个label标签，2个命令按钮Command
'*****************************************************************************
Option Explicit
Dim HirpCounter As Long
Private Sub Form_Load()
Dim cjllim As LARGE_INTEGER

On Error Resume Next

Form1.Caption = "真正的动态秒表（小时：分：秒.毫秒）"
Form1.BackColor = &H0&
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"
Label7.Caption = "00:00:00.000"
Label1.BackColor = &H0&
'Label1.ForeColor = &HFF00&
Label7.BackColor = &H0&
'Label7.ForeColor = &HFF00&
Label1.Font.Name = "Arial Rounded MT Bold"
Label1.Font.Size = 24
Label1.ForeColor = &H80FF&
Label2.ForeColor = &HFFFF00
Label3.ForeColor = Label2.ForeColor
Label4.ForeColor = Label2.ForeColor
Label5.ForeColor = Label2.ForeColor
Label6.ForeColor = Label2.ForeColor
Label7.ForeColor = &H80FF&
'取得主机板上时钟的频率
HirpCounter = QueryPerformanceFrequency(cjllim)
If HirpCounter = 0 Then GoTo chenjl1031
'频率除以1000就得出时钟1毫秒震动的次数
'时钟频率PerMSFreq在有的计算机上是正数，在有的计算机上是负数。
PerMSFreq = (cjllim.highpart * 65536 + cjllim.lowpart) \ 1000
Debug.Print "PerMSFreq=" & PerMSFreq
Exit Sub
chenjl1031:
MsgBox ("Your computer does not support a high-resolution performance counter!" & Chr(13) & Chr(10) & "(你的计算机不支持高精度计数器!)")
End Sub
Private Sub Command1_Click()
Dim lagTick1 As LARGE_INTEGER
Dim lagTick2 As LARGE_INTEGER
Dim lTen As Currency, x As Currency
'Dim h_1 As Long, m_1 As Long, s_1 As Long, ms_1 As Long
'Dim cjlms_1 As String ', s As String
On Error GoTo chenjl1031 'On Error Resume Next

HiCountStart = 0
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, TIME_PERIODIC) '间隔时间为1毫秒

'主要问题在下面红色部分，算法不正确
If HirpCounter = 0 Then Exit Sub
lTen = 1 * Abs(PerMSFreq) '1毫秒震动的次数。PerMSFreq为正数时，这个等式有误差，影响不大；PerMSFreq为负数时，这个式子不正确，等式右边表达式应该如何变换？
Call QueryPerformanceCounter(lagTick1)
lagTick2 = lagTick1

Do While True
If Command2.Enabled = False Then Exit Do
Call QueryPerformanceCounter(lagTick2)
x = Abs(CCur(lagTick2.highpart * 65536) + CCur(lagTick2.lowpart))
x = x - Abs(CCur(lagTick1.highpart * 65536) + CCur(lagTick1.lowpart))
x = Abs(x)
If (x > lTen) Then '时钟超过1毫秒震动的次数就执行IF内的语句
lagTick1 = lagTick2
HiCountStart = HiCountStart + 0.001
HirpCounter = CLng(HiCountStart * 1000)
Hirpc.h = Int(HirpCounter / 3600000) '计算小时
Hirpc.m = Int((HirpCounter Mod 3600000) / 60000) '计算分钟
If Hirpc.m >= 60 Then
Hirpc.m = 0: Hirpc.h = Hirpc.h + 1
End If
Hirpc.s = Int((HirpCounter Mod 3600000) Mod 60000) / 1000 '计算秒钟
If Hirpc.s >= 60 Then
Hirpc.s = 0: Hirpc.m = Hirpc.m + 1
End If
Hirpc.ms = ((HirpCounter Mod 3600000) Mod 60000) Mod 1000 '计算毫秒数
Label7.Caption = Format(Hirpc.h, "00") & ":" & Format(Hirpc.m, "00") & ":" & Format(Hirpc.s, "00") & "." & Format(Hirpc.ms, "000")
End If
DoEvents
Loop Exit Sub
chenjl1031: MsgBox ("错误信息：" & Err.Description & "！")
End Sub
Private Sub Command2_Click()
On Error Resume Next
Command2.Enabled = False
Command1.Enabled = True
EndTime = GetTickCount '记住结束时间
Call timeKillEvent(TimeID) '删除多媒体计时器标识
Label3.Caption = "结束时间：" & TimeLabel(EndTime)
Label4.Caption = "真正的运行时间：" & TimeLabel(GetTickCount - StartTime)
Form1.Caption = "多媒体计时器运行了" & Format(MediaCounter.h, "00") & "小时" & Format(MediaCounter.m, "00") & "分" & Format(MediaCounter.s, "00") & "秒" & Format(MediaCounter.ms, "000"） & "毫秒"
End Sub

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



...全文
516 10 打赏 收藏 转发到动态 举报
写回复
用AI写文章
10 条回复
切换为时间正序
请发表友善的回复…
发表回复
东方之珠 2008-01-03
  • 打赏
  • 举报
 回复
多媒体计时器确实很精确，据资料显示，误差在10毫秒以下。

=============================================================

这个64位的值不太好用。经常崩溃，有时一运行就崩溃，有时运行几秒钟就崩溃，有时退出程序后崩溃...，等等N多这样的问题，即使用Double型数据也一样。不过有一条经验：在高速频繁运行的代码中不能外调自定义函数，或者过于复杂的表达式，比如Timer中，但也不是绝对的，有时候又行。
东方之珠 2008-01-03
  • 打赏
  • 举报
 回复
搞定了，已经解决了。结合Timer事件可以做到不间断计时。关键是LARGE_INTEGER类型数据的使用有技巧。
Tiger_Zhao 2008-01-03
  • 打赏
  • 举报
 回复
一直用高精度计时器做性能测试，用了七八年没什么问题。
8楼的应该自我检讨。
china_bai 2008-01-02
  • 打赏
  • 举报
 回复
我曾经利用多媒体定时器在C++环境下搞了一个精确计时的控件，感觉效果还不错。比VB自带的Timer控件精确了很多。

不知道楼主的这个VB版本的，运行的效果怎么样？精确么?
嗷嗷叫的老马 2008-01-02
  • 打赏
  • 举报
 回复
我当时一看这个64位的值,就懒得弄了

反正我是计时,要求的是里面的值作为一个基准而已

至于这个值是一个什么样的值,在这个应用里面是无所谓的~~~

于是草草乘10000了事:)
东方之珠 2008-01-02
  • 打赏
  • 举报
 回复
老马元旦还算玩得可以啊！虽然郁闷，但有事情做，还算很充实嘛！你和陈辉都是高手，是计算机给了你们这样一个机会，一个发挥自己的舞台！
祝你们新年有新的开始，有新的好运，有新的收获，有新的成就！

------------------------------------------------------------------------------
我上面那个代码，用了2种计时器来计时，这样可以作个比较。
问题的关键是LARGE_INTEGER型数据的转换问题， 我在2台计算机上作了比较，在一台电脑上为正值，另一台为负值。我在网上找了2个转换函数，瞧瞧，就是下面这2个，居然不一样，后来经过验证，后一个（即ClargeInt）是对的，但还不知道有没有BUG。至于那些计算、转换成标签，那是难不住我这个数学系的高材生了！
你的代码很专业，我一定会加进一些你的思想。

Public Function GetRealSize(Longsize As LARGE_INTEGER) As Double

'用来从LARGE_INTEGER型变量中换算出实际的大小
With Longsize
If .highpart < 0 Then
GetRealSize = (2 ^ 32 - 1 - .highpart) * (2 ^ 32 - 1)
Else
GetRealSize = .highpart * (2 ^ 32 - 1)
End If
If .lowpart < 0 Then
GetRealSize = GetRealSize + (2 ^ 32 - 1 - .lowpart)
Else
GetRealSize = GetRealSize + .lowpart
End If
End With
End Function


Public Function ClargeInt(Lo As Long, Hi As Long) As Double
'this function converts the large_integer data type to a double
Dim dbllo As Double, dblhi As Double

If Lo < 0 Then
dbllo = 2 ^ 32 + Lo
Else
dbllo = Lo
End If

If Hi < 0 Then
dblhi = 2 ^ 32 + Hi
Else
dblhi = Hi
End If
ClargeInt = dbllo + dblhi * 2 ^ 32
End Function
嗷嗷叫的老马 2007-12-30
  • 打赏
  • 举报
 回复
有问题........

    If tmpValue > 0 Then                '还没搞完?那就进去除'''

        tmpValueA = tmpValue Mod 1000

        tmpValue = tmpValue - tmpValueA

        SS = tmpValue / 1000

        If SS = 60 Then     '如果等于60秒,当然向分钟进军..

            MM = MM + 1     '再来一个MM~~~~

            SS = 0

            If MM = 60 Then     '如果有60个MM了...

                HH = HH + 1     '加一个小时..

                MM = 0          '没有MM了....T_T

            End If

        End If

        MS = tmpValueA      '整了一圈还有剩?那就是毫秒了.

    End If


这里应该这样改:

    If tmpValue > 1000 Then                '还没搞完?那就进去除'''

        tmpValueA = tmpValue Mod 1000

        tmpValue = tmpValue - tmpValueA

        SS = tmpValue / 1000

        If SS = 60 Then     '如果等于60秒,当然向分钟进军..

            MM = MM + 1     '再来一个MM~~~~

            SS = 0

            If MM = 60 Then     '如果有60个MM了...

                HH = HH + 1     '加一个小时..

                MM = 0          '没有MM了....T_T

            End If

        End If

        tmpValue = tmpValueA      '整了一圈还有剩?那就是毫秒了.

    End If

    MS = tmpValue


剩下的毫秒应该在1000以上时,才进去除....

好,目前貌似是没什么明显的问题了.....睡觉去.....
嗷嗷叫的老马 2007-12-30
  • 打赏
  • 举报
 回复
这个是我弄的:

http://www.m5home.com/blog/attachments/month_0712/f2007123023848.rar

代码:

窗体上需要一个按钮,一个文本框,一个标签...都是默认名称.

按钮控制启停,文本框显示经过的毫秒数,标签显示转换为HH:MM:SS:MS格式的时间.

只是大概地按上面的思路写的,没有考虑太多,仅作为思路的实现.

由于计数器本身是系统的,因此程序本身无论受到什么样的干扰,理论上都是与系统同步的.

我自己试过按住窗体不放(当然是用鼠标按了.......),准确~~~~

'简单的一个计时器,理论上来说是精确到毫秒吧....

'嗷嗷叫的老马

'紫水晶工作室   http://www.m5home.com

'PS:

'没有那个耐心等3600秒....只是手工在文本框里输入了不同的数字简单地验证了一下毫秒转换成HH:MM:SS:MS的算法...

'不知道会不会有BUG...要用的话自己处理:)

Option Explicit



Private Declare Function QueryPerformanceCounter Lib "kernel32" ( _

     ByVal lpPerformanceCount As Long) As Long

Private Declare Function QueryPerformanceFrequency Lib "kernel32" ( _

     ByVal lpFrequency As Long) As Long

Private Declare Sub Sleep Lib "kernel32.dll" ( _

     ByVal dwMilliseconds As Long)



Private msValue As Long                 '1毫秒所需要的计数值

Private TimerOff As Boolean             '定时器过程是否已经退出



Private Sub Command1_Click()

    With Command1

        If .Tag = "0" Then

            .Caption = "停止计时"

            .Tag = "1"

            Label1.Caption = ""

            TimerOff = False

            Timer1.Enabled = True

        Else

            TimerOff = True

            .Caption = "开始计时"

            .Tag = "0"

        End If

    End With

End Sub



Private Sub Form_Load()

    Dim I As Long, CountValue As Currency         '1秒的基准值

    

    Label1.Caption = "00:00:00:000"

    Text1.Text = 0

    With Command1

        .Caption = "开始计时"

        .Tag = "0"

    End With

    Call QueryPerformanceFrequency(VarPtr(CountValue))      '得到1秒计数值

    CountValue = CountValue * 10000     '本来应该使用LARGE_INTEGER结构,懒得弄了...直接乘10000换成整数吧...

    Debug.Print CountValue

    msValue = CountValue / 1000             '得到1毫秒计数值

End Sub



Private Sub Form_Unload(Cancel As Integer)

    If TimerOff <> True Then

        TimerOff = True

        DoEvents

    End If

End Sub



Private Sub Text1_Change()

    '在这里完成毫秒到HH:MM:SS:MS的换算

    Dim HH As Long, MM As Long, SS As Long, MS As Long

    Dim tmpValue As Currency, tmpValueA As Currency, tmpValueB As Currency, tmpValueC As Currency, tmpValueD As Currency

    

    tmpValue = CCur(Text1.Text)         '目前这里面就是经过的毫秒数

    

    If tmpValue > 3600000 Then          '够一小时了?那就进去除~~~

        tmpValueA = tmpValue Mod 3600000

        tmpValue = tmpValue - tmpValueA     '先减余数.....

        HH = tmpValue / 3600000         '那这里一定是整数...

        tmpValue = tmpValueA    '剩下的....

    End If

    If tmpValue > 60000 Then            '够一分钟了?那就进去除....

        tmpValueA = tmpValue Mod 60000

        tmpValue = tmpValue - tmpValueA     '....同上

        MM = tmpValue / 60000       '......

        If MM = 60 Then         '如果等于60分钟,当然是向小时进一位...

            HH = HH + 1

            MM = 0

        End If

        tmpValue = tmpValueA    '.....

    End If

    If tmpValue > 0 Then                '还没搞完?那就进去除'''

        tmpValueA = tmpValue Mod 1000

        tmpValue = tmpValue - tmpValueA

        SS = tmpValue / 1000

        If SS = 60 Then     '如果等于60秒,当然向分钟进军..

            MM = MM + 1     '再来一个MM~~~~

            SS = 0

            If MM = 60 Then     '如果有60个MM了...

                HH = HH + 1     '加一个小时..

                MM = 0          '没有MM了....T_T

            End If

        End If

        MS = tmpValueA      '整了一圈还有剩?那就是毫秒了.

    End If

    Label1.Caption = HH & ":" & MM & ":" & SS & ":" & MS

End Sub



Private Sub Timer1_Timer()

    Dim tmpTimeA As Currency, tmpTimeB As Currency, tmpTimeC As Currency, tmpTimeD As Currency     '单位是ms

    

    Timer1.Enabled = False

    Call QueryPerformanceCounter(VarPtr(tmpTimeA))

    tmpTimeA = tmpTimeA * 10000     '开始计时的基准值

    Do

        Call QueryPerformanceCounter(VarPtr(tmpTimeB))

        tmpTimeB = tmpTimeB * 10000

        tmpTimeC = tmpTimeB - tmpTimeA      '以后只需要计算经过多少秒,并换算成HH:MM:SS:MS格式就OK.

        If tmpTimeC > tmpTimeD + msValue Then       '以1毫秒为单位来更新界面吧...实际还是太快了点.

            tmpTimeD = tmpTimeC

            Text1.Text = tmpTimeD / msValue     '无论怎么拖,怎么整~~~反正是准的.....

            Sleep 1     '既然反正都是准的...小睡一会,降降CPU占用率....

            DoEvents    '处理一下界面堆积的消息

        End If

    Loop While TimerOff = False

End Sub
嗷嗷叫的老马 2007-12-30
  • 打赏
  • 举报
 回复
谢谢LZ,也祝各位节日快乐~~~

这两天晚上都很郁闷.

先是昨晚,被陈辉这臭小子压着打,爆了我一晚上的头.....(出来混,迟早是要还的....你给我记住.....)

然后是今晚.....进去所谓的"服务器反作弊"房间,开了CD,一样让人家的子弹老跟着我的头跑......

难道我真的老了?!

真郁闷~~~怎么总感觉别人是在作弊呀.....-_-b

哎.

扯远了....呵呵

LZ可能把问题复杂化了.

反正你的要求是"计时"嘛~~~搞复杂了.

我想了一下流程,如下:

一,记下开始时间;

二,用当前时间减去开始时间;

三,把差换算成所需要的HH:MM:SS:MS格式就行了.

这里的关键在于第二步.

这一步里面所记录的时间,不应该由程序自身去处理,而应该从系统里面取得.

这才是使用QueryPerformanceCounter和QueryPerformanceFrequency的意义.
Tiger_Zhao 2007-12-29
  • 打赏
  • 举报
 回复 
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Any) As Long

Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Any) As Long



sub main()

    dim dStart as double, dFinish as double, dFrequency as double, vTimeSpan as variant

    QueryPerformanceCounter dStart

    ...

    QueryPerformanceCounter dFinish

    QueryPerformanceFrequency dFrequency

    vTimeSpan = CDec(dFinish - dStart)/dFrequency

    debug.print "耗时 " & formatnumber(vTimeSpan,7) & " 秒"

end sub
VB 微秒级精确计时程序源码
【工控老马出品，必属精品，亲测校正，质量保证】 资源名：VB 微秒级精确计时程序源码 资源类型：程序源代码 源码说明： 基于VB写的实现微秒级精确计时功能的程序源码 代码完整适合学习借鉴 适合人群：新手及有一定...
VB写的倒计时程序源码
【工控老马出品，必属精品，亲测校正，质量保证】 资源名：VB写的倒计时程序源码 资源类型：程序源代码 源码说明： 这是使用VB写的倒计时程序 界面写的很好看 功能完善 适合人群：新手及有一定经验的开发人员
西门子PLC工程实例源码第572期：老外的焊接程序，带有触摸屏！.zip
【工控老马出品，必属精品，亲测校正，质量保证】 资源名：西门子PLC工程实例源码第572期：老外的焊接程序，带有触摸屏！.zip 资源类型：西门子PLC工程实例源码 源码说明： 全部项目源码都是经过测试校正后百分百...
全球国家，省份，城市 三级联动
这是从腾讯QQ注册的所在地， 所获取出来的数据，如有问题问老马！
modbus TCP协议 VB通讯程序源码
需要的童鞋们，自行下载喽，下载资源分会有些高，毕竟花了不少心血嘛，\(^o^)/~ 附件中包括VB modbus TCP 源码，以及可执行文件。 有什么疑问或建议，请下载后在评价中写出，或给我发信息，谢谢。
VB基础类

7,763

社区成员

197,609

社区内容

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

加载中

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

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

+ 用AI写文章