Excel VBA:メッセージボックスを一定時間表示し、その後分岐を行いたい

Question

お世話になります。
ExcelVBAについてご教示いただけますでしょうか。

◆環境
Windows7
Microsoft Excel for Office365 MSO(16.0.11126.20192) 32ビット

◆やりたいこと
１．とあるセルに「する」と入力されていればVBAを自動実行させる。
※コード上ではauto_start

２．その際、メッセージボックスを5秒間表示し、その間に中止を選択すれば
自動実行を停止
※コード上では「vbYes」を選択時に処理停止

３．選択しないで5秒経過すると自動実行開始

◆現状
実行すると、メッセージはポップアップされますが、5秒以上経過しても選択待機のままとなります。

◆現在のコード
※参考ページ

Dim WSH As Object, re As Long
Set WSH = CreateObject("Wscript.Shell")

If auto_start = "する" Then
    re = WSH.PopUp(Text:="自動実行を中止しますか？", SecondsToWait:=5, Type:=vbYesNo + vbQuestion)
    If re = vbYes Then
        Set WSH = Nothing
        End
    End If
    
    Set WSH = Nothing
    
    Call "自動実行したい処理"
End If

何か不足している情報等ございましたらご指摘いただけると助かります。

Answer 1

解決方法ではなく参考情報です。
私の環境で何回かやっていると、閉じることは閉じるのですが妙に時間がかかる事がありました。

そこで以下のように、フォームを作成しボタンを押すとメッセージボックスが出るようにして
ボタンを連打してみました。

左上のメッセージが一番最初に作成され、一番右下が一番最後に作成されたメッセージボックスです。
左上のメッセージボックスから順番に消えていくかと思ったのですが、
実際には右下のメッセージボックス(新しい方)から消えていきました。(左上が最後)

推測ですが、
Wscript.Shell が、どこか別の処理を優先して動かしており
質問主さんのメッセージボックスの処理まで手が回っていない状態(カウントダウンが動いていない)なのではないかと思いました。

あくまで私の推測です、参考までに。

Comments

[torisan]

少し調べましたが、今ひとつ解決策がみつかりませんでした。。私ならユーザーフォームで代用と思います。

[Yoichinn]

ご確認頂きありがとうございます。
今回は、Popupの直前にDoEventsを入れることで正しく動作いたしました。
頂いた情報は今後の参考にさせていただきます。
今後とも宜しくお願いいたします

Answer 2

記載してあるソースでやってみましたが５秒”くらい”で終了してましたね。
ただ、一部記事等でVBAではWSH.Popupは不安定という記載を見つけました。

その記事では以下の方法を記載してました。
参考までに。

MessageBoxTimeoutというHiddenAPIを使用したサンプルです。

Private Declare Function MessageBoxTimeoutA Lib "User32" _
(ByVal Hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long

Private Const MB_TIMEOUT = &H7D00


Private Sub test()
Dim re As Long

If auto_start = "する" Then
    If TimerMsgbox Then
        'Call "自動実行したい処理"
    End If

End If

End Sub

Function TimerMsgbox() As Boolean

Dim Sec As Long
Dim Result As Long

Sec = 5 * 1000 '5秒
sMsg = "自動実行を中止しますか？"

TimerMsgbox = False

Result = MessageBoxTimeoutA(Application.Hwnd, sMsg, _
Application.Name, vbOKCancel + vbMsgBoxSetForeground, 0&, Sec)

Select Case Result
Case vbOK
    TimerMsgbox = True
Case vbCancel
    TimerMsgbox = False
Case MB_TIMEOUT
    TimerMsgbox = True
End Select

End Function

Comments

[Yoichinn]

ありがとうございます！
このような方法もあるんですね！！
一度試してみます

今回はPopupの直前にDoEventsを入れることで解決いたしました。
今後とも宜しくお願いいたします。

Answer 3

手元で確認しましたが、動作的には問題ありませんでした。
auto_start の値が設定されていないとか、"自動実行したい処理"内でエラーになっているなどを確認されてはどうでしょうか。

Comments

[Yoichinn]

ご回答頂きありがとうございます！

ご指摘いただいた点について確認いたしました。
Debug.Printでauto_startの内容を確認しましたが、「する」が選択されておりました。
後続させる処理についても、「いいえ」を選択するとそのまま正しく動作いたしました。

ただ、5秒以上放置してもメッセージが消えず次に進みません。
ご指摘いただいた点以外で、何か要因は考えられますでしょうか。
※記載が漏れておりましたが、Workbook_Openに上記コードを記載しております

現状：以下の箇所で5秒経ってもポップアップが消えてくれないため、放置しても先に進まない
re = WSH.PopUp(Text:="自動実行を中止しますか？", SecondsToWait:=5, Type:=vbYesNo + vbQuestion)

[sazi]

先ずは、メッセージに関する部分だけで検証されてみて下さい。
期待通りでなければ、環境依存ですし、期待どおりなら、他の処理と組み合わせてどの処理が影響しているかを検証してどの処理に関連しているかを絞り込んでみて下さい。

[sazi]

気休めですけど。PopUpの直前にDoEvents入れてみるとか。

[Yoichinn]

ありがとうございます。
結論、DoEventsを入れると動きました！

Dim WSH As Object, re As Long
Set WSH = CreateObject("Wscript.Shell")

If auto_start = "する" Then
DoEvents
re = WSH.PopUp(Text:="自動実行を中止しますか？", SecondsToWait:=5, Type:=vbYesNo + vbQuestion)
If re = vbYes Then
Set WSH = Nothing
End
End If

Set WSH = Nothing

Call "自動実行したい処理"
End If