Esta es una respuesta larga, pero hay mucho terreno que cubrir: también es una respuesta tardía, pero las cosas han cambiado desde que algunas de las respuestas a esta (y preguntas similares) se publicaron en la pila. Eso apesta como una aspiradora con CA de triple fase, porque eran buenas respuestas cuando se publicaban y se pensaba mucho en ellas.
La versión corta es: Me di cuenta de que la solución Script WsShell Popup dejó de funcionar para mí en VBA hace un año, y codifiqué una devolución de llamada del temporizador de API en funcionamiento para la función VBA MsgBox.
Vaya directamente al código debajo del encabezado Código VBA para llamar a un cuadro de mensaje con un tiempo de espera Si necesita una respuesta con prisa, y yo lo hice, tengo literalmente miles de instancias de un sustituto de ‘MsgPopup’ que se descarta automáticamente para VBA.MsgBox para redactar, y el código a continuación encaja en un módulo autónomo.
Sin embargo, los codificadores de VBA aquí, incluido yo mismo, necesitan una explicación de por qué el código perfectamente bueno ya no parece funcionar. Y si comprende las razones, es posible que pueda utilizar la solución parcial para los cuadros de diálogo ‘Cancelar’, enterrados en el texto.
Me di cuenta de que la solución Script WsShell Popup dejó de funcionar para mí en VBA hace un año: se ignoraba el tiempo de espera ‘SecondsToWait’ y el cuadro de diálogo simplemente permanecía como el familiar VBA.MsgBox:
MsgPopup = objWShell.PopUp(Prompt, SecondsToWait, Title, Buttons)
Y creo que sé la razón: ya no puede enviar un mensaje WM_CLOSE o WM_QUIT a una ventana de diálogo desde cualquier lugar que no sea el hilo que lo abrió. Asimismo, la función User32 DestroyWindow () no cerrará una ventana de diálogo a menos que sea llamada por el hilo que abrió el diálogo.
A alguien en Redmond no le gusta la idea de que un script se ejecute en segundo plano y envíe comandos WM_CLOSE a todas esas advertencias esenciales que detienen su trabajo (y, en estos días, hacer que desaparezcan permanentemente necesita privilegios de administrador local).
No puedo imagina quién escribiría un guión como ese, ¡es una idea terrible!
Hay consecuencias y daños colaterales a esa decisión: los objetos WsScript.Popup () en el entorno VBA de un solo subproceso implementan su tiempo de espera ‘SecondsToWait’ usando una devolución de llamada de Timer, y esa devolución de llamada envía un mensaje WM_CLOSE, o algo así … se ignora en la mayoría de los casos, porque es un hilo de devolución de llamada, no el hilo propietario del diálogo.
usted podría haz que funcione en una ventana emergente con un botón ‘CANCELAR’, y quedará claro por qué es en uno o dos minutos.
Intenté escribir una devolución de llamada del temporizador en WM_CLOSE la ventana emergente, y eso también me falló, en la mayoría de los casos.
Probé algunas devoluciones de llamada de API exóticas para alterar la ventana VBA.MsgBox y WsShell.Popup, y ahora puedo decirles que no funcionaron. No puede trabajar con lo que no está allí: esas ventanas de diálogo son muy simples y la mayoría de ellas no contienen ninguna funcionalidad, en absoluto, excepto las respuestas en los clics de los botones: Sí, No, Aceptar, Cancelar, Abortar. , Reintentar, Ignorar y Ayuda.
‘Cancelar’ es interesante: parece que obtiene un obsequio de la API primitiva de Windows para los cuadros de diálogo integrados cuando especifica vbOKCancel o vbRetryCancel o vbYesNoCancel – la función ‘Cancelar’ se implementa automáticamente con un botón ‘cerrar’ en la barra de menú del cuadro de diálogo (no lo obtienes con los otros botones, pero siéntete libre de probarlo con un cuadro de diálogo que contiene ‘Ignorar’), lo que significa que ….
Los diálogos de WsShell.Popup () a veces responderán al tiempo de espera de SecondsToWait si tienen una opción ‘Cancelar’.
objWShell.PopUp("Test Me", 10, "Dialog Test", vbQuestion + vbOkCancel)
Esa podría ser una solución suficientemente buena para alguien que lea esto, si todo lo que quisiera fuera que las funciones WsShell.Popup () respondieran al parámetro SecondsToWait nuevamente.
Esto también significa que puede enviar mensajes WM_CLOSE al cuadro de diálogo ‘Cancelar’ utilizando la llamada API SendMessage () en una devolución de llamada:
SendMessage(hwndDlgBox, WM_CLOSE, ByVal 0&, ByVal 0&)
Estrictamente hablando, esto solo debería funcionar para WM_SYSCOMMAND, SC_CLOSE mensaje: el cuadro ‘cerrar’ en la barra de comandos es un menú de ‘sistema’ con una clase especial de comandos pero, como dije, estamos obteniendo obsequios de la API de Windows.
Hice que eso funcionara y comencé a pensar: Si solo puedo trabajar con lo que hay, tal vez sea mejor que averigüe qué hay en realidad…
Y la respuesta resulta ser obvia: los cuadros de diálogo tienen su propio conjunto de parámetros de mensaje 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
Y, como estos son los mensajes de ‘usuario’ que devuelven las respuestas del usuario a la persona que llama (es decir, el hilo de llamada) del cuadro de diálogo, el cuadro de diálogo está feliz de aceptarlos y cerrarse.
Puede interrogar una ventana de diálogo para ver si implementa un comando en particular y, si lo hace, puede enviar ese comando:
If GetDlgItem(hWndMsgBox, vbRetry) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, vbRetry, 0&
Exit For
End If
El desafío restante es detectar un ‘Tiempo de espera’ e interceptar la respuesta del cuadro de mensaje que regresa, y sustituir nuestro propio valor: -1 si seguimos la convención establecida por el WsShell.Popup() función. Entonces, nuestro contenedor ‘msgPopup’ para un cuadro de mensaje con un tiempo de espera debe hacer tres cosas:
- Llame a nuestro temporizador de API para el cierre demorado del diálogo;
- Abra el cuadro de mensaje, pasando los parámetros habituales;
- O bien: detecte un tiempo de espera y sustituya la respuesta de ‘tiempo de espera’ …
… O devuelva la respuesta del usuario al cuadro de diálogo, si respondió a tiempo
En otros lugares, debemos declarar las llamadas a la API para todo esto, y absolutamente debe tener una función ‘TimerProc’ declarada públicamente para que la API de Timer la llame. Esa función tiene que existir, y tiene que ejecutarse hasta ‘Función final’ sin errores ni puntos de interrupción, cualquier interrupción, y API Timer () llamará la ira del sistema operativo.
Código de VBA para llamar a un cuadro de mensaje con un tiempo de espera:
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
Y aquí están las declaraciones de la API: tenga en cuenta las declaraciones condicionales para VBA7, Windows de 64 bits y 32 bits sin formato:
' 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
Una nota final: agradecería sugerencias de mejora de desarrolladores experimentados de MFC C ++, ya que comprenderá mucho mejor los conceptos básicos de transmisión de mensajes de Windows que subyacen a una ventana de ‘Diálogo’: trabajo en un lenguaje demasiado simplificado y es Es probable que las simplificaciones excesivas en mi entendimiento hayan cruzado la línea hacia errores absolutos en mi explicación.
Ir con Respuesta A. la solución Win32. Esto cumple con los requisitos y es robusto a partir de las pruebas realizadas hasta ahora.
Declare Function MessageBoxTimeout Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As Long, _
ByVal wLanguageID As Long, _
ByVal lngMilliseconds As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Sub MsgBoxDelay()
Const cmsg As String = "Yes or No? leaving this window for 1 min is the same as clicking Yes."
Const cTitle As String = "popup window"
Dim retval As Long
retval = MessageBoxTimeout(FindWindow(vbNullString, Title), cmsg, cTitle, 4, 0, 60000)
If retval <> 7 Then
Call MethodFoo
End If
End Sub
Fácil
Call CreateObject("WScript.Shell").Popup("Timed message box", 1, "Title", vbOKOnly)
Nos encantaría que puedieras difundir esta reseña si te ayudó.