1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
| Option Explicit
Private Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SleepEx Lib "kernel32" (ByVal dwMilliseconds As Long, ByVal bAlertable As Long) As Long
Private Sub Command1_Click()
Dim x As Long, y As Long, ret As String, t As Currency
Dim frequency As Currency, liStart As LARGE_INTEGER, liStop As LARGE_INTEGER, cStart As Currency, cStop As Currency
Const k0 As Long = 0
Const k1 As Long = 250
Me.ProgressBar1.Min = k0
Me.ProgressBar1.Max = k1
frequency = GetFrequency()
If frequency <> 0 Then
For x = k0 To k1
QueryPerformanceCounter liStart
SleepEx x, False
QueryPerformanceCounter liStop
cStart = LargeInteger2Currency(liStart)
cStop = LargeInteger2Currency(liStop)
t = (cStop - cStart) / frequency
ret = ret & IIf(ret <> "", vbCrLf, "") & x & vbTab & t
Me.ProgressBar1.Value = x
Next
End If
Clipboard.Clear
Clipboard.SetText vbtab & frequency & vbCrLf & ret
MsgBox "Test End"
Unload Me
End Sub
Private Function GetFrequency() As Currency
Dim liFrequency As LARGE_INTEGER
If QueryPerformanceFrequency(liFrequency) <> 0 Then GetFrequency = LargeInteger2Currency(liFrequency)
End Function
Private Function LargeInteger2Currency(liInput As LARGE_INTEGER) As Currency
CopyMemory LargeInteger2Currency, liInput, LenB(liInput)
LargeInteger2Currency = LargeInteger2Currency * 10000
End Function |
Partager