rivate Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SendMessage Lib "User32" Alias "SendMessageA" ( _
ByVal hWnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Long) As Long
Private Declare PtrSafe Function SetTimer Lib "user32.dll" ( _
ByVal hWnd As LongPtr, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32.dll" ( _
ByVal hWnd As LongPtr, _
ByVal nIDEvent As Long) As Long
Private Declare Function DestroyWindow Lib "user32.dll" ( _
ByVal hWnd As LongPtr) As Long
Private Const WM_CLOSE As Long = &H10
Private MsgBoxWindowTitle As String
Private TimeOutDéclenché As Boolean
Private TimerID As Long
'-----------------------
'Sub MsgBox avec TimeOut
'
'Return: Valeurs MsgBox
' -1 si TimeOut
'-----------------------
Function MsgBoxTemporisé(Texte As String, Boutons As Integer, Titre As String, TimerMilliSecondes As Long) As Integer
Dim RetVal As Integer
Const DefaultExcelTitle = "Microsoft Excel"
'Initialisations
If Len(Titre) Then MsgBoxWindowTitle = Titre Else MsgBoxWindowTitle = DefaultExcelTitle
TimeOutDéclenché = False
'Set Timer
If TimerMilliSecondes > 0 Then TimerID = SetTimer(0, 0, TimerMilliSecondes, AddressOf MsgBoxTimeOut)
'MsgBox
RetVal = MsgBox(Texte, Boutons, MsgBoxWindowTitle)
'Kill Timer
If TimerID Then KillTimer 0, TimerID
TimerID = 0
'Retour
If TimeOutDéclenché Then MsgBoxTemporisé = -1 Else MsgBoxTemporisé = RetVal
End Function
'-------------------------------------
'Sub de déclenchement TimeOut du Timer
'-------------------------------------
Private Sub MsgBoxTimeOut()
Dim hWnd As LongPtr
Dim ProcessId As Long
Dim lng As Long
Static Count As Integer
Count = Count + 1
If TimerID Then KillTimer 0, TimerID
TimerID = 0
'Kill MsgBox Window (la 1ère ou la 2ème instance)
hWnd = FindWindow(vbNullString, MsgBoxWindowTitle)
DestroyWindow hWnd
'Le DestroyWindow provoque un 2ème affichage du MsgBox sans sortir du MsgBox initial
'Il faut relancer le Timer pour tuer au plus vite cette 2ème instance de MsgBox
If Count = 1 Then TimerID = SetTimer(0, 0, 10, AddressOf MsgBoxTimeOut) Else Count = 0
'Flag Timer déclenché
TimeOutDéclenché = True
End Sub
'---------------------
'Test MsgBox temporisé
'---------------------
Sub Test_MsgBoxTemporisé()
Dim RetVal As Integer
'RetVal = MsgBoxTemporisé("Message d'information pendant 1 seconde et demi", 0, "", 1500)
'GoSub AfficheRetour
RetVal = MsgBoxTemporisé("Cliquer un bouton avant 2 secondes", vbYesNo, "Temps limité !", 2000)
GoSub AfficheRetour
Exit Sub
AfficheRetour:
Select Case RetVal
Case -1
MsgBox "Time Out"
Case vbOK
MsgBox "Bouton <Ok> cliqué."
Case vbYes
MsgBox "Bouton <Oui> cliqué."
Case vbNo
MsgBox "Bouton <Non> cliqué."
Case vbCancel
MsgBox "Bouton <Annuler> cliqué."
Case Else
MsgBox "Code retour = " & RetVal
End Select
Return
End Sub