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中，怎麼調用 倒計時功能？