[转载请注明出处]EXE演示程序下载地址：http://download.csdn.net/source/330199

这是前一遍文章《真正的精确到毫秒级的动态秒表》的改进，改进了前一遍文章只能在VB开发环境中运行，而编译成EXE文件不能运行的错误（一开始计时就崩溃）。同时，增加了高精度计时器的演示。

'标准模块：Module1.bas
Option Explicit

Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
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 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 '毫秒
    us As Long '微秒
End Type
Public MediaCounter As msTime, Hirpc As msTime '声明2个结构类型变量

'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.Caption可以看出来，只是显示到屏幕上没有跟上进度。
       Dim X As Double
       MediaCount = MediaCount + 0.01
       X = MediaCount * 1000  '单位毫秒
       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
          If MediaCounter.m >= 60 Then
             MediaCounter.m = 0: MediaCounter.h = MediaCounter.h + 1
          End If
       End If
       MediaCounter.ms = Int((X Mod 3600000) Mod 60000) Mod 1000 '计算毫秒数
       Form1.Label1.Caption = Format(MediaCounter.h, "00") & ":" & Format(MediaCounter.m, "00") & ":" & Format(MediaCounter.s, "00") & "." & Format(MediaCounter.ms, "000")
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
          If MediaCounter.m >= 60 Then
             MediaCounter.m = 0: MediaCounter.h = MediaCounter.h + 1
          End If
       End If
       MediaCounter.ms = Int((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

Public Function GetRealSize(Lo As Long, Hi As Long) As Double
       
        '用来从LARGE_INTEGER型变量中换算出实际的大小
        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
        GetRealSize = dbllo + dblhi * 2 ^ 32
End Function

 

'Form1的窗体模块
'***********************************************************************************
'用多媒体计数器和高精度运行计数器做的两种计时器对比
'作者：chenjl1031(东方之珠)
'***********************************************************************************
'Form1窗体上共需7个label标签，2个命令按钮Command,1个Timer计时器，1个文本框HRPCounter
'***********************************************************************************
Option Explicit
Private HirpCounter As Long  '判断计算机是否支持高精度运行计数器
Private PerMSFreq As Long '时钟每毫秒震动的次数,=计时基数
Private ExitTimer As Boolean '是否退出计时器对象，即计时器对象是否还在工作

Private Sub Form_Load()
      Dim cjllim As LARGE_INTEGER
     
      On Error Resume Next
      HRPCounter.Visible = False
      TimeCounter.Interval = 2
      TimeCounter.Enabled = False
      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"
      Label5.Caption = "多媒体计时器"
      Label6.Caption = "高精度运行计时器"
      Label7.Caption = "00:00:00.000.000"
      Label1.BackColor = &H0&
      Label7.BackColor = &H0&
      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 = (GetRealSize(cjllim.lowpart, cjllim.highpart)) / 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()
      On Error GoTo chenjl1031
      Command1.Enabled = False
      Command2.Enabled = True
      Label3.Caption = "结束时间：" & "00:00:00.000"
      Label4.Caption = "真正的运行时间：" & "00:00:00.000"
      MediaCount = 0
      HRPCounter.Text = ""
      Label7.Caption = "00:00:00.000.000"
      Label7.Refresh
      StartTime = GetTickCount '记住开始时间
      Label2.Caption = "开始时间：" & TimeLabel(StartTime)
      TimeID = timeSetEvent(10, 0, AddressOf TimeSEProc, 1, TIME_PERIODIC) '间隔时间为10毫秒
     
      If HirpCounter = 0 Then Exit Sub
      ExitTimer = False: TimeCounter.Enabled = True
      Exit Sub
chenjl1031:
      MsgBox ("错误信息：" & Err.Description & "！")
End Sub
Private Sub Command2_Click()
    
      On Error Resume Next
      ExitTimer = True: TimeCounter.Enabled = False
      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)
        If Command2.Enabled = True Then Call timeKillEvent(TimeID)  '删除多媒体计时器标识
        If ExitTimer <> True Then
           ExitTimer = True: DoEvents
        End If
        Unload Me: End
End Sub

Private Sub TimeCounter_Timer()
        '利用Do循环，可以做到不间断计时，并且不受外界影响
        Dim LagTick1 As LARGE_INTEGER, LagTick2 As LARGE_INTEGER
        Dim StartSize As Double, CountDoingSize As Double, X As Double, Xoffset As Double
        'Dim h As Long, m As Long, s As Long, ms As Long, us As Long
        Dim TimeValue As Double, ST As Double
        On Error Resume Next
        TimeCounter.Enabled = False
        Call QueryPerformanceCounter(LagTick1)
        StartSize = IIf(LagTick1.lowpart < 0, 2 ^ 32 + LagTick1.lowpart, LagTick1.lowpart)
        StartSize = StartSize + (2 ^ 32) * IIf(LagTick1.highpart < 0, 2 ^ 32 + LagTick1.highpart, LagTick1.highpart)
        Do
            Call QueryPerformanceCounter(LagTick2)
            CountDoingSize = IIf(LagTick2.lowpart < 0, 2 ^ 32 + LagTick2.lowpart, LagTick2.lowpart)
            CountDoingSize = CountDoingSize + (2 ^ 32) * IIf(LagTick2.highpart < 0, 2 ^ 32 + LagTick2.highpart, LagTick2.highpart)
            X = (CountDoingSize) - (StartSize)
            If X > Xoffset + 2 * PerMSFreq Then '每2毫秒更新1次显示时间
               Xoffset = X
               HRPCounter.Text = Xoffset / PerMSFreq '换算成毫秒
               TimeValue = CDbl(HRPCounter.Text)    '累积的毫秒数
               Hirpc.h = Int(TimeValue / 3600000) '计算小时
               Hirpc.m = Int((TimeValue Mod 3600000) / 60000) '计算分钟
               If Hirpc.m >= 60 Then
                  Hirpc.m = 0: Hirpc.h = Hirpc.h + 1
               End If
               Hirpc.s = Int((TimeValue Mod 3600000) Mod 60000) / 1000 '计算秒钟
               If Hirpc.s >= 60 Then
                  Hirpc.s = 0: Hirpc.m = Hirpc.m + 1
                  If Hirpc.m >= 60 Then
                     Hirpc.m = 0: Hirpc.h = Hirpc.h + 1
                  End If
               End If
               Hirpc.ms = Int((TimeValue Mod 3600000) Mod 60000) Mod 1000 '计算毫秒数
               Hirpc.us = (CDbl(HRPCounter.Text) * 1000) Mod 1000 '取得微秒数
               Label7.Caption = Format(Hirpc.h, "00") & ":" & Format(Hirpc.m, "00") & ":" & Format(Hirpc.s, "00") & "." & Format(Hirpc.ms, "000") & "." & Format(Hirpc.us, "000")
               Sleep 1
               DoEvents
            End If
        Loop While ExitTimer = False
End Sub