求VB.net能用的 延迟函数，不会假死的那种(不想用Timer)，文中已经有VB6的代码了，会修改的请进

[cjjxcn]

我以前在vb6用过一个好用的延迟函数，现在想改在VB.net下用：

以下是VB6下的类，请放进模块：WaitedTimer

Option Explicit
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Const WAIT_ABANDONED& = &H80&
Private Const WAIT_ABANDONED_0& = &H80&
Private Const WAIT_FAILED& = -1&
Private Const WAIT_IO_COMPLETION& = &HC0&
Private Const WAIT_OBJECT_0& = 0
Private Const WAIT_OBJECT_1& = 1
Private Const WAIT_TIMEOUT& = &H102&
Private Const INFINITE = &HFFFF
Private Const ERROR_ALREADY_EXISTS = 183&
Private Const QS_HOTKEY& = &H80
Private Const QS_KEY& = &H1
Private Const QS_MOUSEBUTTON& = &H4
Private Const QS_MOUSEMOVE& = &H2
Private Const QS_PAINT& = &H20
Private Const QS_POSTMESSAGE& = &H8
Private Const QS_SENDMESSAGE& = &H40
Private Const QS_TIMER& = &H10
Private Const QS_MOUSE& = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Private Const QS_INPUT& = (QS_MOUSE Or QS_KEY)
Private Const QS_ALLEVENTS& = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)
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)
Private Const UNITS = 4294967296#
Private Const MAX_LONG = -2147483648#
Private Declare Function CreateWaitableTimer Lib "kernel32" Alias "CreateWaitableTimerA" (ByVal lpSemaphoreAttributes As Long, ByVal bManualReset As Long, ByVal lpName As String) As Long
Private Declare Function OpenWaitableTimer Lib "kernel32" Alias "OpenWaitableTimerA" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As String) As Long
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
Private Declare Function CancelWaitableTimer Lib "kernel32" (ByVal hTimer As Long)
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
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
Private mlTimer As Long
Private Sub Class_Terminate()
On Error Resume Next
If mlTimer <> 0 Then CloseHandle mlTimer
End Sub
Public Sub Wait(MilliSeconds As Long)
On Error GoTo ErrHandler
Dim ft As FILETIME
Dim lBusy As Long
Dim lRet As Long
Dim dblDelay As Double
Dim dblDelayLow As Double

mlTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer" & Format$(Now(), "NNSS"))

If Err.LastDllError <> ERROR_ALREADY_EXISTS Then
ft.dwLowDateTime = -1
ft.dwHighDateTime = -1
lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, 0)
End If

dblDelay = CDbl(MilliSeconds) * 10000#

ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1
dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))

If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLow

ft.dwLowDateTime = CLng(dblDelayLow)
lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, False)

Do
lBusy = MsgWaitForMultipleObjects(1, mlTimer, False, INFINITE, QS_ALLINPUT&)
DoEvents
Loop Until lBusy = WAIT_OBJECT_0

CloseHandle mlTimer
mlTimer = 0
Exit Sub

ErrHandler:
Err.Raise Err.Number, Err.Source, "[clsWaitableTimer.Wait]" & Err.Description
End Sub



在实例中直接用：

wait (5000) '表示延迟5秒，非常方便

[cjjxcn]

引用 2 楼 脆皮大雪糕 的回复:

又想阻塞等待延迟，又想不假死，那么建议你用多线程。 VB.net里面能够很完美的支持多线程，不需要像VB6那么麻烦

怎么实现，请举个例子，谢谢

[脆皮大雪糕]

https://blog.csdn.net/u011788252/article/details/53895473 其中第一种方法就是线程的sleep。只不过你如果不用多线程，那么就是当前主线程sleep，于是就假死了。 至于多线程，问度娘 关键字: VB.net thread

[cjjxcn]

我现在想将上面的函数改到VB.net下用，请高手修改

[脆皮大雪糕]

又想阻塞等待延迟，又想不假死，那么建议你用多线程。 VB.net里面能够很完美的支持多线程，不需要像VB6那么麻烦

[现在还是人类]

vb里面有个doevent函数，可以作为函数等待时用，用个全局变量或对象属性作为函数结束的开关，不管是在线程或Timer事件里处理完相关过程设置一下那个全局变量或对象属性就可以结束属性了，比如：

Public IsExecSearch As Long
Public NowCount As Long
Public MaxCount As Long
Private Sub Command1_Click()
    MsgBox "准备开始计时，请观察窗口标题变化", 64, "提示"
    Me.Caption = "当前计时：" & NowCount & "/" & MaxCount
    Call ExecWait(3)
    MsgBox "函数执行完成", 64, "提示"
End Sub
Public Function ExecWait(ByVal in_second As Long) As Long
   Dim rd As Long
   ' 初始化定时器
   Timer1.Enabled = False
   Timer1.Interval = 1000
   ' 判断函数执行状态
   If IsExecSearch Then
      ' 如果为执行状态则退出函数并返回调用失败
      ExecSearch = 0
      Exit Function
   End If
   IsExecSearch = 1         ' 设置函数为执行状态
   NowCount = 0             ' 初始化当前计数器
   MaxCount = in_second     ' 初始化要等待的秒数
   Timer1.Enabled = True    ' 打开定时器开始计时
   ' 进入死循环等待
   Do
      DoEvents              ' 关键函数可以让你的函数不会有假死现象
   Loop While IsExecSearch  ' 判断公共变量为 true 就进行循环
   ExecSearch = 1           ' 返回函数调用成功
End Function

Private Sub Timer1_Timer()
    NowCount = NowCount + 1
    If NowCount > MaxCount Then
        Timer1.Enabled = False
        IsExecSearch = 0
        Exit Sub
    End If
    Me.Caption = "当前计时：" & NowCount & "/" & MaxCount
End Sub

 

[cjjxcn]

还没找到完美答案

[神奇的VBA]

task.daly好像是这个?在异步中可以严实不卡界面