VBA，如何使用类msgbox的效果，但是让窗口过几秒自动关闭？ （未完成）

 

msgbox函数的局限性：

 

• 没有定时关闭的功能。
• 有字符数限制。
• msgbox总是拥有焦点，只要对话框不关闭，代码就不会停止运行。
   

 

 

1 window Scripting Host（WSH）的Popup方法--实测2007可能不好用

• 这个算WINDOW的api吗？  CreateObject("wscript.shell").popUp
• 不知道为啥测试不好用，可能是EXCEL版本的问题
• 无论是直接使用，还是先赋值给变量都不行
• 另外这个方法也不能显示倒计时秒数，

Sub test_sample31()
CreateObject("wscript.shell").popUp "1秒钟关闭", 1, "提示", vbYes
End Sub


Sub test_sample32()
'Scripting Host（WSH）的Popup方法。
Dim w1 As Object
Set w1 = CreateObject("wscript.shell")
w1.popUp "3秒自动关闭", 3, "确定", vbOKOnly    'vbInformation
'Set w1 = Nothing

End Sub

  

 

相关资料

因为这的是WSCRIPT的POPUP，你不可能在EXCEL中找到帮助——严格地来说，它不是属于EXCEL系统的提示框，在WINDOW SCRIPT的帮助文档中可以查到

这个POPUP有一个小问题，因为与EXCEL不是同一系的，如果用户在弹出POPUP时，仍然可以自由操作切回EXCEL的画面（例如用鼠标点击POPUP以外的EXCEL表格，USERFORM等），这个时候POPUP的计时可能不算，也就是说，POPUP上的流程（5秒计时）并没有完成，而EXCEL的操作也不能完成，对用户而言，他可能“发现”整个工作都中止了（其实POPUP还在画面外等着计时），这一点在编程时请注意一下

WshShell.Popup
Popup 方法显示一个弹出式消息框窗口，消息框中包含的消息由 strText 指定。该消息框的窗口标题由 strTitle 指定。若 strTitle 省略，则窗口标题为 Windows Scripting Host。
语法
WshShell.Popup(strText, [natSecondsToWait], [strTitle], [natType]) = intButton
注释
若提供 natSecondsToWait 且其值大于零，则消息框在 natSecondsToWait 秒后关闭。
natType 的含义与其在 Win32? MessageBox 函数中相同。下表显示 natType 中的值及含义。下表中的值可以组合。
按钮类型
值 说明 
0 显示“确定”按钮 
1 显示“确定”和“取消”按钮 
2 显示“终止”、“重试”和“忽略”按钮 
3 显示“是”、“否”和“取消”按钮 
4 显示“是”和“否”按钮 
5 显示“重试”和“取消”按钮 

图标类型
值 说明 
16 显示停止标记图标 
32 显示问号图标 
48 显示感叹号图标 
64 显示信息标记图标 

以上两个表并不涵盖 natType 的所有值。完整的列表请参阅 Win32 文档。
返回值 intButton 指示用户所单击的按扭编号。若用户在 natSecondsToWait 秒之前不单击按扭，则 intButton 设置为 -1 。
值 说明 
1 “确定”按扭 
2 “取消”按扭 
3 “终止”按扭 
4 “重试”按扭 
5 “忽略”按扭 
6 “是”按扭 
7 “否”按扭 

示例
Set WshShell = Wscript.CreateObject("Wscript.Shell")
WshShell.Popup "Where do you want to go today?"

 

 

参考

https://blog.csdn.net/robertsong2004/article/details/50640003

https://wenku.baidu.com/view/2f9ca328227916888486d772.html

http://club.excelhome.net/thread-949073-1-1.html

http://www.excelpx.com/forum.php?mod=viewthread&tid=267643&page=1

http://club.excelhome.net/thread-255177-1-1.html

http://www.excelpx.com/thread-298415-1-1.html

 

 

2  加载其他库的功能--好用

2.1 加载lib  "user32" Alias "messageBoxTimeOutA"

• 参考内容：http://club.excelhome.net/thread-590980-1-1.html
• 但是这个还不带倒计时，考虑下怎么加一个

Private Declare Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long, ByVal wlange As Long, ByVal dwTimeout As Long) As Long

 Sub test1a()
    MessageBoxTimeout 0, "倒计5秒时关闭", "自动关闭", 0, 0, 5000
 End Sub

 

3 加载其他库 Lib "user32"--好用

• 写自定义过程
• 但是第一个过程不为什么不能被执行？
• 参考 http://www.excelpx.com/thread-267643-1-1.html

Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElaspe As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Dim TID As Long
Const Sec = 3  '可以在这里修改时间
Sub CloseTest(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)
   Application.SendKeys "~", True '发送回符，即关闭窗口的命令
   KillTimer 0, TID
End Sub
Sub 三秒钟自动关闭()
  TID = SetTimer(0, 0, Sec * 1000, AddressOf CloseTest)
  MsgBox Sec & "  秒种自动关闭窗口", 65, "提示"
End Sub

 

同一个人写的

参考 http://www.excelpx.com/thread-298415-1-1.html

Option Explicit
Public MyModem As New MSCommLib.MSComm
Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElaspe As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Dim TID As Long
Const Sec = 3  '可以在这里修改时间
Sub CloseTest(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)
        Application.SendKeys "~", True '发送回符，即关闭窗口的命令
        KillTimer 0, TID
End Sub
Sub Dial_Number()
    Dim PhoneNum As String
    Dim PhoneNam As String
    Dim MsgboxRst
    PhoneNum = ActiveCell.Text
    PhoneNam = Cells(ActiveCell.Row, 3) + " at " + _
               Cells(1, ActiveCell.Column) + Chr(13) + PhoneNum
    'Remove shenzhen city code 0755
    If Left(PhoneNum, 4) = "0755" Then
        PhoneNum = Mid(PhoneNum, 8)
    End If
    'add prefix for Out_line
    If Len(PhoneNum) > 4 Then
        PhoneNum = "" + PhoneNum
    End If
    'Add prefix for Long-Distance call
    If Len(PhoneNum) > 4 And Mid(PhoneNum, 2, 1) = "0" Then
        PhoneNum = "911808" + PhoneNum
    End If
    'Replace right most "-" with ,,,, i.e. pause for extension
    PhoneNum = Replace(PhoneNum, "-", ",,,,,,")
    'activecell.Columns
    On Error GoTo ErrRpt
    MyModem.CommPort = 1
    If MyModem.PortOpen = False Then
        MyModem.PortOpen = True
    End If
    MyModem.OutPut = "ATDT" + PhoneNum + Chr(13)
    TID = SetTimer(0, 0, Sec * 1000, AddressOf CloseTest)
    MsgboxRst = MsgBox(PhoneNam, 0, "Calling...")
    MyModem.PortOpen = False
    Exit Sub
ErrRpt:
    TID = SetTimer(0, 0, Sec * 1000, AddressOf CloseTest)
    MsgBox "设置或连接不正确！", 65, "提示"
End Sub

 

 

 

这个为什么不好用？

这个不行，但是可以在msgbox出来后点击确定按纽后 几秒钟关闭。  
Sub sss()
Dim t, k
MsgBox "点击确定后5秒钟关闭文件“
t = Timer
k = i + 1
Do
Loop Until Timer - t = 5    ' 5秒
ActiveWorkbook.Save    ‘保存
ActiveWorkbook.Close  ' 关闭
End Sub

这名是关闭之前保存，03、07都没问题。
如果不用这句 会跳出是否保存的对话框
如果以选择关闭之前不保存那可以用
Application.DisplayAlerts = False  替换 ActiveWorkbook.Save

 

 

修改一下，把wType定义成vbMsgBoxStyle，这样可以提示输入VBA里的MsgBox常数了。
Private Declare Function MsgBoxEx 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
Private Sub TestMsgboxEx()
    Dim ret As Long
    ret = MsgBoxEx(0, "请选择", "两秒后自动关闭", vbYesNo + vbInformation, 1, 2000)
    If ret = 32000 Then
        Debug.Print "超时关闭"
    ElseIf ret = vbYes Then
        Debug.Print "选择Yes"
    ElseIf ret = vbNo Then
        Debug.Print "选择No"
    End If
End Sub

 

这个为啥不好用？

http://www.excelpx.com/thread-298415-1-1.html

Option Explicit

Public Declare Function MsgBoxTimeOut Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long, ByVal wlange As Long, ByVal dwTimeout As Long) As Long

Sub PopupMsgbox(Optional prompt As String = "OK", Optional title As String = "友情提示", Optional seconds As Long = 300)
    MsgBoxTimeOut 0, prompt, title, 64, 0, seconds
End Sub

 

 

这个好用吗？

 好了，很簡單吧！您執行程式時，當   MsgBox   出現   3   秒之後，就會自動關閉了！   
  注意：此方法的限制說明：   
    
  1、當常數設定為   VbAbortRetryIgnore   或   VbYesNo   時，無效！   
  2、在   Design   Time   時，無效，必須   Make   EXE   之後才有效！

参考 https://blog.csdn.net/smallboy_5/article/details/3009872

 Private   Declare   Function   FindWindow   Lib   "user32"   Alias   "FindWindowA"   _   
  (ByVal   lpClassName   As   String,   ByVal   lpWindowName   As   String)   As   Long   
    
  Private   Declare   Function   SendMessage   Lib   "user32"   Alias   "SendMessageA"   _   
  (ByVal   hWnd   As   Long,   ByVal   wMsg   As   Long,   ByVal   wParam   As   Long,   _   
  lParam   As   Any)   As   Long   
    
  Private   Const   WM_CLOSE   =   &H10   
  Private   Const   MsgTitle   As   String   =   "Test   Message"   
  '在表單中加入一個   CommandButton   及一個   Timer   控制項，加入以下程式碼：   
    
  Private   Sub   Command1_Click()   
        Dim   nRet   As   Long   
        Timer1.Interval   =   3000   
        Timer1.Enabled   =   True   
        nRet   =   MsgBox("若您不回應的話，3   秒後此   MsgBox   會自動關閉",   64,   MsgTitle)   
        Timer1.Enabled   =   False   
  End   Sub   
    
  Private   Sub   Timer1_Timer()   
        Dim   hWnd   As   Long   
        hWnd   =   FindWindow(vbNullString,   MsgTitle)   
        Call   SendMessage(hWnd,   WM_CLOSE,   0,   ByVal   0&)   
  End   Sub   

 

 

自己写UI的方法

• 自己写一个小型的form，作为msgbox使用，加限时和各种限时，确定button等，应该是可行的
• 可能难点是：窗体form中，怎么调用 倒计时功能？