Icône de ressource
Bonjour a tous
la question revient souvent comment faire un msgbox temporaire
il y a diverses façons de procéder
la plus courante et connue et le popup de wscript.shell qui possède un argument timeout sauf que ca n'est plus modal et selon les System c'est inopérant
je vais pas m’éterniser sur la méthode avec un userform modal ou pas
non aujourd'hui je vous propose de temporiser le vrai msgbox de vba
pour cela nous allons utiliser les api windows setTimer et Kill timer
en effet la procédure appeler par le settimer est en addressof elle est donc pas bloquée par le modal du msgbox il suffit de la lancer avant le msgbox
@Dudu2 et moi même avons travaillé sur la question suite a une Neme demande de ce type
et nous sommes parvenus a un principe cohérent et stable nous avons donc créer une fonction de msgbox perso avec chacun son style de codage
je propose donc ici les deux versions

version Patricktoulon
j'ai tendance a condenser mais la méthode est assez simple a comprendre
je propose le button par defaut au timeout en optional
VB:
'
'MODELE PATRICKTOULON
'======================================================
'       !! TEMPORISER LE VRAI MSGBOX DE VBA !!
'catégorie boite de dialogue
'Temporisation du vrai msgbox de vba
'Auteurs:patricktoulon sur exceldownload
'Version :1.0; de patricktoulon
'Utilisation des api setTimer et KillTimer
'======================================================

Option Explicit
#If VBA7 Then
    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
#Else
    Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
    Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If
Dim MsgBoxTitle
Dim MsgBoxCloseD As Boolean
Dim TimerID&
Function MsgBoxX( _
         message As String, _
         Optional style As VbMsgBoxStyle = vbOKOnly, _
         Optional titre As String = "", _
         Optional helper As String = "", _
         Optional ByVal contexte As Long = 0, _
         Optional ResponseByDefault As Boolean = False, _
         Optional DelayOfResponse As Long = 3)

    Dim Response$
    titre = IIf(titre = "", "Message Excel!", titre)
    MsgBoxTitle = titre: MsgBoxCloseD = False:
    If DelayOfResponse > 0 Then TimerID = SetTimer(0, 0, DelayOfResponse * 1000, AddressOf CloseMsgBox)
    Response = MsgBox(message, style, titre, helper, contexte)
    If TimerID <> 0 Then KillTimer 0, TimerID: TimerID = 0:
    'réponse "timeout!!" ou le bouton par defaut selon l'argument "ResponseByDefault"
    If MsgBoxCloseD And Not ResponseByDefault Then Response = "timeOut!!"
    MsgBoxX = Response
End Function

Public Sub CloseMsgBox()
    MsgBoxCloseD = True: AppActivate MsgBoxTitle    'flag du close et activation de la fenetre du msgbox
    CreateObject("wscript.shell").SendKeys ("{Enter}")    'touche enter sur le bouton par defaut
End Sub

'EXEMPLE D UTILISATION
'Méthode: msgboxX( [message] , [style+icon+bouton par defaut+fenetre premier plan] , [titre]  ,[reponse par le defautbutton ], [delay])
Sub test()
    Dim rep As String, style As VbMsgBoxStyle   'VbMsgBoxResult
    style = vbAbortRetryIgnore + vbDefaultButton3 + vbInformation + vbMsgBoxSetForeground
    rep = MsgBoxX("salut les loulous", style, "bonjour", DelayOfResponse:=3)
    MsgBox rep
End Sub
'exemple de simple msgbox d'avertissement
Sub test2()
    MsgBoxX "coucou tout lemonde", vbInformation, DelayOfResponse:=3
End Sub
la version de @Dudu2 il a tendance plutôt a s’étaler en terme de code mais la méthode est quasi identique
il ne propose pas le button par défaut au timeout
'=============================
Attention chez moi la version de Dudu2 plante Excel a tout les coups

et je n'ai pas trouvé la raison
'==============================

VB:
'
'MODELE Dudu2
'======================================================
'       !! TEMPORISER LE VRAI MSGBOX DE VBA !!
'catégorie boite de dialogue
'Temporisation du vrai msgbox de vba
'Auteurs: Dudu2 sur exceldownload
'Version :1.0; de Dudu2
'Utilisation des api setTimer et KillTimer
'======================================================





Option Explicit

#If VBA7 Then
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
#Else
Private Declare 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 Function KillTimer Lib "user32.dll" ( _
                                 ByVal hwnd As LongPtr, _
                                 ByVal nIDEvent As Long) As Long
#End If

Private MsgBoxWindowTitle As String
Private MsgBoxTimeOutReached As Boolean

'-------------------------------------------------
'Test / Examples of a regular MsgBox with Time Out
'-------------------------------------------------
Sub Test_MsgBoxTimeOut()
    Dim RetVal As Integer
 
    RetVal = MsgBoxTimeOut("This is the same as a standard MsgBox (no Time Out)")
    GoSub DisplayReturn

    RetVal = MsgBoxTimeOut("1 " & Chr(189) & " second information message", dwMilliseconds:=1500)
    GoSub DisplayReturn

    RetVal = MsgBoxTimeOut("You have 5 seconds to click a button !", vbYesNoCancel + vbInformation, "Limited time", dwMilliseconds:=5000)
    GoSub DisplayReturn
 
    Exit Sub
 
DisplayReturn:
    Select Case RetVal
        Case -1
            MsgBox "Time Out"
        Case vbOK
            MsgBox "<OK> button clicked."
        Case vbCancel
            MsgBox "<Cancel> button clicked."
        Case vbAbort
            MsgBox "<Abort> button clicked."
        Case vbRetry
            MsgBox "<Retry> button clicked."
        Case vbIgnore
            MsgBox "<Ignore> button clicked."
        Case vbYes
            MsgBox "<Yes> button clicked."
        Case vbNo
            MsgBox "<No> button clicked."
        Case Else '???
            MsgBox "Return value = " & RetVal
    End Select
    Return
End Sub
'Test example 2 :simply for warm a user!!!do not ask for an answer, the msgbox is closed either the time out or the ok button
Sub Test2_MsgBoxTimeOut()
MsgBoxTimeOut "simply to warn you the user", dwMilliseconds:=2000
End Sub
Sub test()
MsgBoxTimeOut "Avec un titre vide", title:="", dwMilliseconds:=1500

End Sub


'-----------------------------
'MsgBox with Time Out Function
'-----------------------------
'https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/msgbox-function
'Call:   MsgBoxTimeOut (prompt, [ buttons, ] [ title, ] [ helpfile, context ,] [ dwMilliseconds ])
'Return: MsgBox values
'        -1 if TimeOut
'------------------------
Function MsgBoxTimeOut(ByVal prompt As String, _
                       Optional ByVal buttons As Long = 0, _
                       Optional ByRef title As String = "", _
                       Optional ByVal helpfile As String = "", _
                       Optional ByVal context As Long = 0, _
                       Optional ByVal dwMilliseconds As Long = 0) As Integer
    Dim RetVal As Integer
    Dim TimerID As Long
    Const DefaultExcelTitle = "Microsoft Excel"
 
    'Initialisations
    If Len(title) Then MsgBoxWindowTitle = title Else MsgBoxWindowTitle = DefaultExcelTitle
    MsgBoxWindowTitle = title
     MsgBoxTimeOutReached = False
 
    'Set Timer
    If dwMilliseconds > 0 Then TimerID = SetTimer(0, 0, dwMilliseconds, dwMilliseconds), AddressOf MsgBoxTimeOutFunction)
 
    'Standard MsgBox
    RetVal = MsgBox(prompt, buttons, MsgBoxWindowTitle, helpfile, context)
 
    'Kill Timer
    If TimerID Then KillTimer 0, TimerID
 
    'Return value
    If MsgBoxTimeOutReached Then MsgBoxTimeOut = -1 Else MsgBoxTimeOut = RetVal
End Function

'-----------------
'Time Out Function
'-----------------
Private Sub MsgBoxTimeOutFunction()
    'To ensure that SendKeys does not target another application
    AppActivate MsgBoxWindowTitle
 
    'Close MsgBox Window
    SendKeys "{ENTER}"
 
    'Time Out Flag
    MsgBoxTimeOutReached = True
End Sub
je joint un fichier avec les deux exemples pour la démo
Auteur
Dudu2 et Patricktoulon
Version
1.0

Dernières mises à jour

  1. correction sur modele de Dudu2

    juste quelques corrections dans le modele de Dudu2 et démo d'appels successifs dans le model...
Haut Bas