Это длинный ответ, но есть много оснований для его рассмотрения: это также поздний ответ, но все изменилось, так как некоторые ответы на этот (и подобные вопросы) были размещены в стеке.Это отстой, как пылесос на трехфазном переменном токе, потому что они были хорошими ответами, когда они были опубликованы, и много думали о них.
Короткая версия: Я заметил, что Script WsShellВсплывающее решение перестало работать для меня в VBA год назад, и я закодировал работающий обратный вызов таймера API для функции VBA MsgBox.
Перейдите прямо к коду под заголовком VBA-код для вызоваокно сообщения с тайм-аутом , если вам нужен спешный ответ - и я сделал это, у меня есть буквально тысячи экземпляров самозапускающегося MsgPopup, заменяющего VBA.MsgBox для редактирования, и приведенный ниже код вписывается вавтономный модуль.
Однако здесь кодеры VBA, включая меня, нуждаются в некотором объяснении того, почему совершенно хороший код больше не работает.И если вы понимаете причины, вы можете использовать частичный обходной путь для диалогов «Отмена», скрытых в тексте.
Я заметил, что всплывающее решение Script WsShell перестало работать для меня в VBA год назад- Тайм-аут 'SecondsToWait' игнорировался, и диалог просто зависал, как знакомый VBA.MsgBox:
MsgPopup = objWShell.PopUp(Prompt, SecondsToWait, Title, Buttons)
И я думаю, я знаю причину, почему: вы больше не можете отправлять WM_CLOSE или WM_QUITсообщение в диалоговое окно из любого места, кроме потока, который его открыл.Аналогично, функция User32 DestroyWindow () не закроет диалоговое окно, если она не вызвана потоком, открывшим диалоговое окно.
Кому-то в Редмонде не нравится идея сценария, работающего в фоновом режиме и отправляющегоWM_CLOSE подает команды всем тем существенным предупреждениям, которые останавливают вашу работу (и, в наши дни, чтобы заставить их уйти навсегда, нужны права локального администратора).
Я не могу представить , кто написал бы такой сценарий, это ужасная идея!
У этого решения есть последствия и сопутствующий ущерб: WsScript.Popup () объекты в однопоточной среде VBA реализуют свой тайм-аут SecondsToWait с помощью обратного вызова Timer, и этот обратный вызов отправляет сообщение WM_CLOSE или что-то подобное ... Что в большинстве случаев игнорируется, поскольку это поток обратного вызова, а непоток владельца для этого диалога.
Вы могли бы заставить его работать во всплывающем окне с помощью кнопки 'ОТМЕНА', и станет понятно, почему это происходит через минуту или две.
Я пытался написать таймер обратного вызова для WM_CLOSE во всплывающем окне, но в большинстве случаев это тоже не получалось.
Я пробовал несколько экзотических обратных вызовов API, чтобы связываться с окнами VBA.MsgBox и WsShell.Popup, и теперь я могу сказать вам, что они не работали.Вы не можете работать с тем, чего нет: эти диалоговые окна очень просты, и большинство из них вообще не содержат никакой функциональности, за исключением ответов на нажатия кнопок - Да, Нет, ОК, Отмена, Отмена, Повторить, Пропустить и Справка.
«Отмена» - это интересный вопрос: кажется, что вы получаете бесплатную от примитивного Windows API для встроенных диалогов, когда вы указываете vbOKCancel или vbRetryCancel илиvbYesNoCancel - функция «Отмена» автоматически реализуется с помощью кнопки «Закрыть» в строке меню диалогового окна (вы не получаете этого с другими кнопками, но можете попробовать ее в диалоговом окне, содержащем «Игнорировать»),это означает, что ....
Диалоги WsShell.Popup () иногда будут реагировать на тайм-аут SecondsToWait, если у них есть опция «Отмена».
objWShell.PopUp("Test Me", 10, "Dialog Test", vbQuestion + vbOkCancel)
Это может быть достаточно хорошимОбходной путь для тех, кто читает это, если все, что вам нужно, это получить функции WsShell.Popup () для повторного ответа на параметр SecondsToWait.
Это также означает, что вы можете отправить сообщение WM_CLOSEПерейдите в диалог «Отмена» с помощью вызова API SendMessage () для обратного вызова:
SendMessage(hwndDlgBox, WM_CLOSE, ByVal 0&, ByVal 0&)
Строго говоря, это должно работать только для сообщения WM_SYSCOMMAND, SC_CLOSE - поле «Закрыть» на панели команд - это «системное» меню со специальным классом команд, но, как я уже сказал, мы получаем халяву от Windows API.
Я получил это на работу, и я начал думать: Если бы я мог работать только с тем, что там, возможно, я бы лучше выяснил, что на самом деле там ...
И ответ оказывается очевидным: диалоговые окна имеют свой собственный набор параметров сообщения WM_COMMAND -
' Dialog window message parameters, replicating Enum vbMsgBoxResult:
CONST dlgOK As Long = 1
CONST dlgCANCEL As Long = 2
CONST dlgABORT As Long = 3
CONST dlgRETRY As Long = 4
CONST dlgIGNORE As Long = 5
CONST dlgYES As Long = 6
CONST dlgNO As Long = 7
И, поскольку это «пользовательские» сообщения, которые возвращают пользовательские ответы на вызывающего (то есть вызывающего потока) диалогового окна, диалоговое окно с радостью принимает их и закрывает себя.
Вы можете опросить диалоговое окно, чтобы увидеть, реализует ли оно определенную команду, и, если оно это делает, вы можете отправить эту команду:
If GetDlgItem(hWndMsgBox, vbRetry) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, vbRetry, 0&
Exit For
End If
Остальной задачей является обнаружение «тайм-аута» и перехват возвращаемого ответа «Окна сообщения», а также подстановка собственного значения: -1, если мы следуем соглашению, установленному функцией WsShell.Popup(). Итак, наша оболочка msgPopup для окна сообщений с тайм-аутом должна сделать три вещи:
- Позвоните в наш API Timer для отложенного закрытия диалогового окна;
- Открыть окно сообщения, передав обычные параметры;
- Либо: определить тайм-аут и заменить ответ «тайм-аут» ...
... Или вернуть ответ пользователя в диалог, если он ответил в
время
В других случаях нам нужно объявить вызовы API для всего этого, и мы абсолютно должны иметь публично объявленную функцию 'TimerProc' для вызова API Timer. Эта функция должна существовать, и она должна запускаться до «End Function» без ошибок или точек останова - любое прерывание, и API Timer () вызовет гнев операционной системы.
Код VBA для вызова окна сообщения с тайм-аутом:
Option Explicit
Option Private Module<BR />
' Nigel Heffernan January 2016<BR />
' Modified from code published by Microsoft on MSDN, and on StackOverflow: this code is in<BR />' the public domain.<BR />
' This module implements a message box with a 'timeout'<BR />
' It is similar to implementations of the WsShell.Popup() that use a VB.MessageBox interface
' with an additional 'SecondsToWait' or 'Timeout' parameter.<BR />
Private m_strCaption As String<BR />
Public Function MsgPopup(Optional Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String, _
Optional SecondsToWait As Long = 0) As VbMsgBoxResult<BR />
' Replicates the VBA MsgBox() function, with an added parameter to automatically dismiss the message box after n seconds
' If dismissed automatically, this will return -1: NOT 'cancel', nor the default button choice.<BR />
Dim TimerStart As Single<BR />
If Title = "" Then
Title = ThisWorkbook.Name
End If<BR />
If SecondsToWait > 0 Then
' TimedmessageBox launches a callback to close the MsgBox dialog
TimedMessageBox Title, SecondsToWait
TimerStart = VBA.Timer
End If<BR /><BR />
MsgPopup = MsgBox(Prompt, Buttons, Title)<BR /><BR />
If SecondsToWait > 0 Then
' Catch the timeout, substitute -1 as the response
If (VBA.Timer - TimerStart) >= SecondsToWait Then
MsgPopup = -1
End If
End If<BR />
End Function<BR />
Public Function MsgBoxResultText(ByVal MsgBoxResult As VbMsgBoxResult) As String<BR />' Returns a text value for the integers returned by VBA MsgBox() and WsShell.Popup() dialogs<BR />
' Additional value: 'TIMEOUT', returned when the MsgBoxResult = -1<BR />' All other values return the string 'ERROR'<BR /><BR />
On Error Resume Next<BR /><BR />
If (MsgBoxResult >= vbOK) And (MsgBoxResult <= vbNo) Then
MsgBoxResultText = Split("ERROR,OK,CANCEL,ABORT,RETRY,IGNORE,YES,NO,", ",")(MsgBoxResult)
ElseIf MsgBoxResult = dlgTIMEOUT Then
MsgBoxResultText = "TIMEOUT"
Else
MsgBoxResultText = "ERROR"
End If<BR />End Function
'
'
'
'
'
'
'
'
'
'
Private Property Get MessageBox_Caption() As String
MessageBox_Caption = m_strCaption
End Property<BR />
Private Property Let MessageBox_Caption(NewCaption As String)
m_strCaption = NewCaption
End Property<BR /><BR />
Private Sub TimedMessageBox(Caption As String, Seconds As Long)
On Error Resume Next<BR />
' REQUIRED for Function msgPopup
' Public Sub TimerProcMessageBox MUST EXIST<BR />
MessageBox_Caption = Caption<BR />
SetTimer 0&, 0&, Seconds * 1000, AddressOf TimerProcMessageBox<BR />
Debug.Print "start Timer " & Now<BR />
End Sub<BR />
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows<BR /> ' Use LongLong and LongPtr<BR /><BR />
Public Sub TimerProcMessageBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As LongLong)
On Error Resume Next<BR />
' REQUIRED for Function msgPopup
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx<BR />
' Closes a dialog box (Shell.Popup or VBA.MsgBox) having a caption stored in MessageBox_Caption
' This TimerProc sends *any* message that can close the dialog: the objective is solely to close
' the dialog and resume the VBA thread. Your caller must detect the expired TimerProc interval
' and insert a custom return value (or default) that signals the 'Timeout' for responses.<BR />
' The MsgPopup implementation in this project returns -1 for this 'Timeout'<BR />
Dim hWndMsgBox As LongPtr ' Handle to VBA MsgBox<BR />
KillTimer hWndMsgBox, idEvent<BR />
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)<BR />
If hWndMsgBox <> 0 Then<BR />
' Enumerate WM_COMMAND values
For iDlgCommand = vbOK To vbNo
If GetDlgItem(hWndMsgBox, iDlgCommand) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, iDlgCommand, 0&
Exit For
End If
Next iDlgCommand<BR />
End If<BR />
End Sub<BR />
#ElseIf VBA7 Then ' 64 bit Excel in all environments<BR /> ' Use LongPtr only<BR /><BR />
Public Sub TimerProcMessageBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As Long)
On Error Resume Next<BR />
' REQUIRED for Function msgPopup
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx<BR />
' Closes a dialog box (Shell.Popup or VBA.MsgBox) having a caption stored in MessageBox_Caption
' This TimerProc sends *any* message that can close the dialog: the objective is solely to close
' the dialog and resume the VBA thread. Your caller must detect the expired TimerProc interval
' and insert a custom return value (or default) that signals the 'Timeout' for responses.<BR />
' The MsgPopup implementation in this project returns -1 for this 'Timeout'<BR />
Dim hWndMsgBox As LongPtr ' Handle to VBA MsgBox
Dim iDlgCommand As VbMsgBoxResult ' Dialog command values: OK, CANCEL, YES, NO, etc<BR />
KillTimer hwnd, idEvent<BR />
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)<BR />
If hWndMsgBox <> 0 Then<BR />
' Enumerate WM_COMMAND values
For iDlgCommand = vbOK To vbNo
If GetDlgItem(hWndMsgBox, iDlgCommand) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, iDlgCommand, 0&
Exit For
End If
Next iDlgCommand<BR />
End If<BR />
End Sub<BR />
#Else ' 32 bit Excel<BR /><BR />
Public Sub TimerProcMessageBox(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
On Error Resume Next<BR />
' REQUIRED for Function msgPopup<BR />
' The MsgPopup implementation in this project returns -1 for this 'Timeout'<BR />
Dim hWndMsgBox As Long ' Handle to VBA MsgBox<BR />
KillTimer hwnd, idEvent<BR />
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)<BR />
If hWndMsgBox <> 0 Then<BR />
' Enumerate WM_COMMAND values
For iDlgCommand = vbOK To vbNo
If GetDlgItem(hWndMsgBox, iDlgCommand) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, iDlgCommand, 0&
Exit For
End If
Next iDlgCommand<BR />
End If<BR />
End Sub<BR />
#End If
А вот и объявления API - обратите внимание на условные объявления для VBA7, 64-битной Windows и простой-ванильной 32-битной:
' Explanation of compiler constants for 64-Bit VBA and API declarations :
' https://msdn.microsoft.com/en-us/library/office/ee691831(v=office.14).aspx
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows ' Use LongLong and LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr _
) As Long
Public Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr _
) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" _
(ByVal hWndDlg As LongPtr, _
ByVal nIDDlgItem As Long _
) As LongPtr
#ElseIf VBA7 Then ' VBA7 in all environments, including 32-Bit Office ' Use LongPtr for ptrSafe declarations, LongLong is not available
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" _
(ByVal hWndDlg As LongPtr, _
ByVal nIDDlgItem As Long _
) As LongPtr
#Else
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, _
ByRef lParam As Any _
) As Long
Private Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function GetDlgItem Lib "user32" _<BR /> (ByVal hWndDlg, ByVal nIDDlgItem As Long) As Long
#End If
Private Enum WINDOW_MESSAGE
WM_ACTIVATE = 6
WM_SETFOCUS = 7
WM_KILLFOCUS = 8
WM_PAINT = &HF
WM_CLOSE = &H10
WM_QUIT = &H12
WM_COMMAND = &H111
WM_SYSCOMMAND = &H112
End Enum
' Dialog Box Command IDs - replicates vbMsgBoxResult, with the addition of 'dlgTIMEOUT'
Public Enum DIALOGBOX_COMMAND
dlgTIMEOUT = -1
dlgOK = 1
dlgCANCEL = 2
dlgABORT = 3
dlgRETRY = 4
dlgIGNORE = 5
dlgYES = 6
dlgNO = 7
End Enum
Последнее замечание: я бы приветствовал предложения по улучшению от опытных разработчиков MFC C ++, поскольку вы будете гораздо лучше понимать основные концепции передачи сообщений Windows, лежащие в основе окна «Диалог» - я работаю на упрощенном языке и вполне вероятно, что упрощения в моем понимании перешли черту в прямые ошибки в моем объяснении.