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
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
'==============================
je joint un fichier avec les deux exemples pour la démo
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