在Excel VBA中实现可自动延时关闭的消息框 - 可替代Msgbox函数

用过Excel VBA的应该都知道可以使用msgbox在vba中创建弹出式消息对话框，但是msgbox创建的消息对话框必须人为关闭它，如果不人为干预程序将挂起影响一些自动化程序顺畅度。

微软的官网分享了一个可自动关闭弹出式消息对话框的VB程序，参见Automatically Dismiss a Message Box | Microsoft Learn，但其实它不是真正的自动消失的对话框，因为必须点击OK按钮后才消息框才会延时自动关闭。那么在VBA中如何创建一个完全无需人工干预的延时自动关闭弹出式消息对话框呢？这里分享两种办法：

方法1：可以借助WshShell的Popup方法，代码如下：

Sub Msgbox_AutoDismiss()
'''可自动消失的VBA弹出消息对话框'''
Dim str_Msg As String
Dim str_Title As String
Dim int_DelayTime As Integer
Dim iMsgShell As Object
Set iMsgShell = CreateObject("WScript.Shell")
str_Msg = "这个对话框将自动关闭。"
str_Title = "Auto Dismiss Message Box"
int_DelayTime = 2
iMsgShell.Run "mshta.exe vbscript:close(CreateObject(""WScript.shell"").popup(""" & _
    str_Msg & """," & int_DelayTime & ",""" & str_Title & """,vbInformation))"
End Sub

上面的语句也可写为如下另外一种格式也是可行的

iMsgShell.Run "mshta.exe vbscript:close(CreateObject(""WScript.shell"").popup(""" & str_Msg & """," & int_DelayTime & ",""" & str_Title & """,vbInformation)&(window.close))"

网上有一个广为流传的帖子（参见链接 用vba做一个自动定时关闭的msgbox对话框），其中提到说采用这种"WScript.Shell"的方法未能成功，个人认为这应该程序代码不够完善所致，大家可以对比下代码应该可知为什么。

方法2：可以借助一个未公开的Windows API函数，也可以完美实现自动关闭的消息框，代码如下：

#If Win64 Then '64位
    Private Declare PtrSafe Function Msg_AutoPopupX Lib "user32" Alias "MessageBoxTimeoutA" ( _
        ByVal hwnd As LongPtr, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal wType As VbMsgBoxStyle, _
        ByVal wlange As Long, _
        ByVal dwTimeout As Long) As Long
#Else
    Private Declare Function Msg_AutoPopupX Lib "user32" Alias "MessageBoxTimeoutA" ( _
        ByVal hwnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal wType As VbMsgBoxStyle, _
        ByVal wlange As Long, _
        ByVal dwTimeout As Long) As Long
#End If

Sub Msgbox_AutoDismiss_2()
    Dim msg_State As Long
    msg_State = Msg_AutoPopupX(0, "这个对话框将在3秒后自动关闭。", "Auto Dismiss Message Box", vbInformation, 1, 3000)    
End Sub

只需将以上代码拷贝至Excel VBA编辑器即可使用，这里已经做成了包含代码的Excel文件，有兴趣的可免费下载参考，也可用百度网盘/微信扫码直接下载。

百度网盘链接和提取码: https://pan.baidu.com/s/1p8s4laoRb5ZPR9ryAdve-w?pwd=1u2x 提取码: 1u2x