VB里有没有不占用CPU的超级延迟？

蜡笔不小新

{:soso__12237759026638490920_4:}求助。。。。。。。。

夏冰

1. Option Explicit
   
2. 
   
3. Private Type FILETIME  
   
4.     dwLowDateTime As Long
   
5.     dwHighDateTime As Long
   
6. End Type
   
7. 
   
8. Private Const WAIT_ABANDONED& = &H80&
   
9. Private Const WAIT_ABANDONED_0& = &H80&
   
10. Private Const WAIT_FAILED& = -1&
    
11. Private Const WAIT_IO_COMPLETION& = &HC0&
    
12. Private Const WAIT_OBJECT_0& = 0
    
13. Private Const WAIT_OBJECT_1& = 1
    
14. Private Const WAIT_TIMEOUT& = &H102&
    
15. Private Const INFINITE = &HFFFF
    
16. Private Const ERROR_ALREADY_EXISTS = 183&
    
17. Private Const QS_HOTKEY& = &H80
    
18. Private Const QS_KEY& = &H1
    
19. Private Const QS_MOUSEBUTTON& = &H4
    
20. Private Const QS_MOUSEMOVE& = &H2
    
21. Private Const QS_PAINT& = &H20
    
22. Private Const QS_POSTMESSAGE& = &H8
    
23. Private Const QS_SENDMESSAGE& = &H40
    
24. Private Const QS_TIMER& = &H10
    
25. Private Const QS_MOUSE& = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
    
26. Private Const QS_INPUT& = (QS_MOUSE Or QS_KEY)
    
27. Private Const QS_ALLEVENTS& = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)
    
28. Private Const QS_ALLINPUT& = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)
    
29.   
    
30. Private Const Units = 4294967296#
    
31. Private Const MAX_LONG = -2147483648#
    
32. Private Declare Function CreateWaitableTimer Lib "kernel32" Alias "CreateWaitableTimerA" (ByVal lpSemaphoreAttributes As Long, ByVal bManualReset As Long, ByVal lpName As String) As Long
    
33. Private Declare Function OpenWaitableTimer Lib "kernel32" Alias "OpenWaitableTimerA" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As String) As Long
    
34. Private Declare Function SetWaitableTimer Lib "kernel32" (ByVal hTimer As Long, lpDueTime As FILETIME, ByVal lPeriod As Long, ByVal pfnCompletionRoutine As Long, ByVal lpArgToCompletionRoutine As Long, ByVal fResume As Long) As Long
    
35. Private Declare Function CancelWaitableTimer Lib "kernel32" (ByVal hTimer As Long)
    
36. Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    
37. Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    
38. Private Declare Function MsgWaitForMultipleObjects Lib "user32" (ByVal nCount As Long, pHandles As Long, ByVal fWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
    
39. Private mlTimer As Long
    
40. 
    
41. Private Sub Class_Terminate()
    
42.     On Error Resume Next
    
43.     If mlTimer <> 0 Then CloseHandle mlTimer
    
44. End Sub
    
45. 
    
46. Public Sub Wait(MilliSeconds As Long)
    
47.     On Error GoTo ErrHandler
    
48.     Dim ft As FILETIME
    
49.     Dim lBusy As Long
    
50.     Dim lRet As Long
    
51.     Dim dblDelay As Double
    
52.     Dim dblDelayLow As Double
    
53. 
    
54. mlTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer" & Format$(Now(), "NNSS"))
    
55. 
    
56. If Err.LastDllError <> ERROR_ALREADY_EXISTS Then
    
57.         ft.dwLowDateTime = -1
    
58.         ft.dwHighDateTime = -1
    
59.         lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, 0)
    
60.     End If
    
61. 
    
62. 'Convert the Units to nanoseconds.
    
63.     dblDelay = CDbl(MilliSeconds) * 10000#
    
64. 
    
65. 'By setting the high/low time to a negative number, it tells
    
66.     'the Wait(in SetWaitableTimer) to use an offset time as/
    
67.     'opposed to a hardcoded time. If it were positive, it would
    
68.     'try to convert the value to GMT.
    
69.     ft.dwHighDateTime = -CLng(dblDelay / Units) - 1
    
70.     dblDelayLow = -Units * (dblDelay / Units - Fix(CStr(dblDelay / Units)))
    
71. 
    
72. If dblDelayLow < MAX_LONG Then dblDelayLow = Units + dblDelayLow
    
73. 
    
74. ft.dwLowDateTime = CLng(dblDelayLow)
    
75. lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, False)
    
76. 
    
77. Do
    
78. 
    
79. 'QS_ALLINPUT means that MsgWaitForMultipleObjects will
    
80. 'return every time the thread in which it is running gets
    
81. 'a message. If you wanted to handle messages in here you could,
    
82. 'but by calling Doevents you are letting DefWindowProc
    
83. 'do its normal windows message handling---Like DDE, etc.
    
84. lBusy = MsgWaitForMultipleObjects(1, mlTimer, False, INFINITE, QS_ALLINPUT&)
    
85. DoEvents
    
86. Loop Until lBusy = WAIT_OBJECT_0
    
87. 
    
88. 'Close the handles when you are done with them.
    
89.     CloseHandle mlTimer
    
90.     mlTimer = 0
    
91. Exit Sub
    
92. ErrHandler:
    
93. Err.Raise Err.Number, Err.Source, "[clsWaitableTimer.Wait]" & Err.Description
    
94. End Sub

复制代码

99无敌

就一个超级延迟而已，居然要这么长的代码，vb，汗颜

乔伊

99无敌 发表于 2011-11-17 23:35
就一个超级延迟而已，居然要这么长的代码，vb，汗颜

2楼误导新人啊。。= =想多了，只要加个Doevent就行

萱草若蓠

这个Doevent好！