Это длинный ответ, но есть много тем, которые нужно охватить: это также поздний ответ, но все изменилось с тех пор, как некоторые ответы на этот (и подобные вопросы) были размещены в стеке. Это отстой, как пылесос с трехфазным переменным током, потому что они были хорошими ответами, когда они были опубликованы, и над ними было много размышлений.
Краткая версия: Я заметил, что решение Script WsShell Popup перестало работать для меня в VBA год назад, и я закодировал работающий обратный вызов таймера API для функции VBA MsgBox.
Перейдите сразу к коду под заголовком Код VBA для вызова окна сообщения с тайм-аутом, если вам нужен ответ в спешке — и я сделал, у меня есть буквально тысячи случаев самозакрывающегося ' MsgPopup заменяет VBA.MsgBox для редактирования, а приведенный ниже код вписывается в автономный модуль.
Однако здешним программистам VBA, в том числе и мне, нужно объяснить, почему совершенно хороший код больше не работает. И если вы понимаете причины, вы можете использовать частичный обходной путь для диалогов «Отмена», скрытых в тексте.
Я заметил, что решение Script WsShell Popup перестало работать для меня в 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, и теперь я могу сказать вам, что они не работали. Нельзя работать с тем, чего нет: эти диалоговые окна очень просты и в большинстве из них вообще нет никакой функциональности, кроме ответов на нажатия кнопок - Да, Нет, ОК, Отмена, Прервать , Повторить, Игнорировать и Справка.
'Cancel' is an interesting one: it appears that you get a freebie from the primitive Windows API for built-in dialogs when you specify vbOKCancel or vbRetryCancel or vbYesNoCancel - the 'Cancel' function is automatically implemented with a 'close' button in the dialog's Menu bar (you don't get that with the other buttons, but feel free to try it with a dialog containing 'Ignore'), which means that....
Диалоги 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 для отложенного закрытия диалога;
- Откройте окно сообщения, передав обычные параметры;
- Либо: Обнаружить тайм-аут и подставить ответ 'timeout'...
...Или вернуть ответ пользователя в диалог, если он ответил вовремя
В другом месте нам нужно объявить вызовы API для всего этого, и мы абсолютно должны иметь публично объявленную функцию 'TimerProc' для вызова Timer API. Эта функция должна существовать, и она должна выполняться до «Конца функции» без ошибок или точек останова — любого прерывания, и API Timer() вызовет гнев операционной системы.
Код VBA для вызова окна сообщений с тайм-аутом:
Option Explicit
Option Private Module
' Nigel Heffernan January 2016
' Modified from code published by Microsoft on MSDN, and on StackOverflow: this code is in ' the public domain.
' This module implements a message box with a 'timeout'
' It is similar to implementations of the WsShell.Popup() that use a VB.MessageBox interface
' with an additional 'SecondsToWait' or 'Timeout' parameter.
Private m_strCaption As String
Public Function MsgPopup(Optional Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String, _
Optional SecondsToWait As Long = 0) As VbMsgBoxResult
' 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.
Dim TimerStart As Single
If Title = "" Then
Title = ThisWorkbook.Name
End If
If SecondsToWait > 0 Then
' TimedmessageBox launches a callback to close the MsgBox dialog
TimedMessageBox Title, SecondsToWait
TimerStart = VBA.Timer
End If
MsgPopup = MsgBox(Prompt, Buttons, Title)
If SecondsToWait > 0 Then
' Catch the timeout, substitute -1 as the response
If (VBA.Timer - TimerStart) >= SecondsToWait Then
MsgPopup = -1
End If
End If
End Function
Public Function MsgBoxResultText(ByVal MsgBoxResult As VbMsgBoxResult) As String
' Returns a text value for the integers returned by VBA MsgBox() and WsShell.Popup() dialogs
' Additional value: 'TIMEOUT', returned when the MsgBoxResult = -1 ' All other values return the string 'ERROR'
On Error Resume Next
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
End Function
'
'
'
'
'
'
'
'
'
'
Private Property Get MessageBox_Caption() As String
MessageBox_Caption = m_strCaption
End Property
Private Property Let MessageBox_Caption(NewCaption As String)
m_strCaption = NewCaption
End Property
Private Sub TimedMessageBox(Caption As String, Seconds As Long)
On Error Resume Next
' REQUIRED for Function msgPopup
' Public Sub TimerProcMessageBox MUST EXIST
MessageBox_Caption = Caption
SetTimer 0&, 0&, Seconds * 1000, AddressOf TimerProcMessageBox
Debug.Print "start Timer " & Now
End Sub
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows
' Use LongLong and LongPtr
Public Sub TimerProcMessageBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As LongLong)
On Error Resume Next
' REQUIRED for Function msgPopup
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx
' 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.
' The MsgPopup implementation in this project returns -1 for this 'Timeout'
Dim hWndMsgBox As LongPtr ' Handle to VBA MsgBox
KillTimer hWndMsgBox, idEvent
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)
If hWndMsgBox < > 0 Then
' 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
End If
End Sub
#ElseIf VBA7 Then ' 64 bit Excel in all environments
' Use LongPtr only
Public Sub TimerProcMessageBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As Long)
On Error Resume Next
' REQUIRED for Function msgPopup
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx
' 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.
' The MsgPopup implementation in this project returns -1 for this 'Timeout'
Dim hWndMsgBox As LongPtr ' Handle to VBA MsgBox
Dim iDlgCommand As VbMsgBoxResult ' Dialog command values: OK, CANCEL, YES, NO, etc
KillTimer hwnd, idEvent
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)
If hWndMsgBox < > 0 Then
' 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
End If
End Sub
#Else ' 32 bit Excel
Public Sub TimerProcMessageBox(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
On Error Resume Next
' REQUIRED for Function msgPopup
' The MsgPopup implementation in this project returns -1 for this 'Timeout'
Dim hWndMsgBox As Long ' Handle to VBA MsgBox
KillTimer hwnd, idEvent
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)
If hWndMsgBox < > 0 Then
' 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
End If
End Sub
#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" _
(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, лежащих в основе окна «Диалог». Я работаю на упрощенном языке, и это вероятно, чрезмерное упрощение в моем понимании перешло черту и превратилось в прямые ошибки в моем объяснении.
person
Nigel Heffernan
schedule
01.02.2016
