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

祝节日快乐！改进了很多，但问题还是很多。
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 LongPublic 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 LongPublic 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 TypePublic 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 SubPublic 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 SubPrivate Sub Form_Unload(Cancel As Integer)
        Unload Me
        End
End Sub

解决方案 »

  1.   

    Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Any) As Long
    Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Any) As Longsub 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
      

  2.   

    谢谢LZ,也祝各位节日快乐~~~这两天晚上都很郁闷.先是昨晚,被陈辉这臭小子压着打,爆了我一晚上的头.....(出来混,迟早是要还的....你给我记住.....)然后是今晚.....进去所谓的"服务器反作弊"房间,开了CD,一样让人家的子弹老跟着我的头跑......难道我真的老了?!真郁闷~~~怎么总感觉别人是在作弊呀.....-_-b哎.扯远了....呵呵LZ可能把问题复杂化了.反正你的要求是"计时"嘛~~~搞复杂了.我想了一下流程,如下:一,记下开始时间;二,用当前时间减去开始时间;三,把差换算成所需要的HH:MM:SS:MS格式就行了.这里的关键在于第二步.这一步里面所记录的时间,不应该由程序自身去处理,而应该从系统里面取得.这才是使用QueryPerformanceCounter和QueryPerformanceFrequency的意义.
      

  3.   

    这个是我弄的: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 ExplicitPrivate 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 SubPrivate 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 SubPrivate Sub Form_Unload(Cancel As Integer)
        If TimerOff <> True Then
            TimerOff = True
            DoEvents
        End If
    End SubPrivate 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 SubPrivate 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
      

  4.   

    有问题........    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以上时,才进去除....好,目前貌似是没什么明显的问题了.....睡觉去.....
      

  5.   

        老马元旦还算玩得可以啊！虽然郁闷，但有事情做，还算很充实嘛！你和陈辉都是高手，是计算机给了你们这样一个机会，一个发挥自己的舞台！
        祝你们新年有新的开始，有新的好运，有新的收获，有新的成就！
        
    ------------------------------------------------------------------------------
        我上面那个代码，用了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
      

  6.   

    我曾经利用多媒体定时器在C++环境下搞了一个精确计时的控件，感觉效果还不错。比VB自带的Timer控件精确了很多。不知道楼主的这个VB版本的，运行的效果怎么样？精确么?
      

  7.   

    多媒体计时器确实很精确，据资料显示，误差在10毫秒以下。=============================================================这个64位的值不太好用。经常崩溃，有时一运行就崩溃，有时运行几秒钟就崩溃，有时退出程序后崩溃...，等等N多这样的问题，即使用Double型数据也一样。不过有一条经验：在高速频繁运行的代码中不能外调自定义函数，或者过于复杂的表达式，比如Timer中，但也不是绝对的，有时候又行。
      

  8.   

    搞定了，已经解决了。结合Timer事件可以做到不间断计时。关键是LARGE_INTEGER类型数据的使用有技巧。