[转载请注明出处]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
发表于 @ 2008年01月09日 20:48:00|评论(loading...)|编辑