VBA 改造msgbox 可以倒计时自动关闭

'Download by http://www.NewXing.com
'标准模块：Module1.bas
Option Explicit

Private 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
Private Declare Function timeKillEvent Lib "winmm.dll" (ByVal uID As Long) As Long
Private Const TIME_PERIODIC As Long = 1  '  program for continuous periodic event
Private Const TIME_ONESHOT As Long = 0 '  program timer for single event
'Public MediaCount As Double '累加量

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
'Public Const WM_GETTEXT As Long = &HD&
Private Const WM_SETTEXT As Long = &HC&
Private Const WM_CLOSE As Long = &H10&
Private Const WM_CTLCOLORSTATIC = &H138
 
 
  Const WM_CTLCOLORMSGBOX = &H132
Const WM_CTLCOLOREDIT = &H133
Const WM_CTLCOLORLISTBOX = &H134
Const WM_CTLCOLORBTN = &H135
Const WM_CTLCOLORDLG = &H136
Const WM_CTLCOLORSCROLLBAR = &H137



Private Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function EnumChildWindows Lib "user32.dll" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long

Private TimeID As Long '返回多媒体记时器对象标识
Private Dlghwnd As Long     '对话框句柄
Private Dlgtexthwnd As Long '对话框提示文本句柄
Private MsgboxClosetime As Long '设置对话框关闭时间
Private MsgboxPromtText As String '设置对话框提示文本

'枚举所有顶级窗口
Private Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
       Dim WindowCaption As String, CaptionLength As Long, WindowClassName As String * 256
       CaptionLength = GetWindowTextLength(hWnd)
       WindowCaption = Space(CaptionLength)
       Call GetWindowText(hWnd, WindowCaption, CaptionLength + 1)
       If InStr(1, WindowCaption, MsgboxPromtText) > 0 Then
          Dlghwnd = hWnd
       End If
       EnumWindowsProc = 1
End Function

'枚举所有子窗口
Private Function EnumChildWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
       Dim WindowCaption As String, CaptionLength As Long, WindowClassName As String * 256
       CaptionLength = GetWindowTextLength(hWnd)
       WindowCaption = Space(CaptionLength)
       Call GetWindowText(hWnd, WindowCaption, CaptionLength + 1)
       Call GetClassName(hWnd, WindowClassName, 256)
       If InStr(1, WindowClassName, "Static") > 0 Then
          Dlgtexthwnd = hWnd
       End If
       EnumChildWindowsProc = 1
End Function


'API函数timeSetEvent使用的回调函数
Private Function TimeSetProc(ByVal uID As Long, ByVal uMsg As Long, ByVal dwUser As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
       Dim cText As String
       Static MediaCount As Double ', Msghwnd1 As Long, Msghwnd2 As Long
       MediaCount = MediaCount + 0.5
       If Dlgtexthwnd > 0 Then
          cText = CStr(MsgboxClosetime - Fix(MediaCount)) & "秒后自动关闭！"
        
          Call SendMessage(Dlgtexthwnd, WM_SETTEXT, Len(cText), ByVal cText)
         
         Dim vNewValue As OLE_COLOR
         
          If Val(cText) = 0 Then
             MediaCount = 0
             Call SendMessage(Dlghwnd, WM_CLOSE, 0, 0) '时间到，关闭对话框
             Call timeKillEvent(TimeID)  '删除多媒体计时器标识
          End If
       Else
          Call EnumWindows(AddressOf EnumWindowsProc, 0)
          If Dlghwnd > 0 Then
             Call EnumChildWindows(Dlghwnd, AddressOf EnumChildWindowsProc, 0)
          End If
       End If
       TimeSetProc = 1
End Function
Sub asdsa(a As OLE_COLOR)
    
End Sub


'定时关闭对话框：Closetime参数设置对话框关闭时间；Msgboxtitle参数设置对话框提示文本；vbButtons参数是设置对话框按钮及图标。
Public Function Fixedtimeclosemsgbox(ByVal Closetime As Long, ByVal Msgboxtitle As String, Optional vbButtons As VbMsgBoxStyle = vbOKOnly) As Long
     Dim Information As Long
     Dlghwnd = 0: Dlgtexthwnd = 0
     MsgboxClosetime = Closetime
     MsgboxPromtText = Msgboxtitle
     TimeID = timeSetEvent(500, 0, AddressOf TimeSetProc, 1, TIME_PERIODIC) '时间间隔为500毫秒
     Information = MsgBox(Closetime & "秒后自动关闭！", vbButtons, Msgboxtitle) '定义msgbox对话框
     Call timeKillEvent(TimeID) '删除多媒体计时器标识
     Fixedtimeclosemsgbox = 1
End Function