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
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
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
'Example Name:Performance CounterPrivate Type LARGE_INTEGER
LowPart AsLong
HighPart AsLongEnd Type
PrivateDeclareFunction QueryPerformanceCounter Lib"kernel32" (lpPerformanceCount As LARGE_INTEGER) AsLongPrivateDeclareFunction QueryPerformanceFrequency Lib"kernel32" (lpFrequency As LARGE_INTEGER) AsLongPrivateDeclareSub CopyMemory Lib"kernel32.dll"Alias"RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length AsLong)
PrivateSub Form_Load()
'KPD-Team 2001'URL: http://www.allapi.net/'E-Mail: KPDTeam@Allapi.netDim T AsLong, 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 counterIf QueryPerformanceFrequency(liFrequency) =0ThenMsgBox"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 somethingFor T =0To100000
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 resultMsgBox"Time: "+CStr((cuStop - cuStart) / cuFrequency) +" seconds"EndIfEnd SubPrivateFunction 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 *10000End Function