Microsoft 365 Validation (bouton "no") automatique d'une Msgbox après 1mn

[Fab117]

Hello,
Je souhaiterais faire une macro qui tourne en boucle, mais m'offre régulièrement une porte de sortie.
J'ai donc fait une boucle qui m'ouvre une Msgbox.
Si je clique "yes", il sort de la macro.
Si je clique "No" il déroule la macro et retourne sur la Msgbox.

Existe-t-il un moyen pour qu'après 1mn il "clique" tout seul sur le bouton "No" de la Msgbox si entre temps je n'ai pas réagit.

Autrement dit:
Il ouvre la Msgbox.
J'ai 1mn pour cliquer sur "yes", sinon il déroule le reste de la macro, puis relance la Msgbox.
Et ainsi de suite jusqu'à ce que je clique "yes"

Do Until Condition
    If MsgBox("Cliquer Yes pour sortir de la macro", vbYesNo, "Demande de confirmation") = vbYes Then
            Exit Sub
    End If
Loop

Merci d'avance de votre aide.

Fab

 

[Dudu2]

non je vais tester d'autre api qui mettent une fenêtre au premier plan

Ok dans ce cas: AppActivate MsgBoxWindowTitle

Ce qui implique, au moins par prudence, d'avoir un titre de fenêtre MsgBox non nul.

 

[Dudu2]

Bon, ben cette fois on doit enfin y être...

#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

'-----------------------------
'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 ByVal 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
    MsgBoxTimeOutReached = False
  
    'Set Timer
    If dwMilliseconds > 0 Then TimerID = SetTimer(0, 0, IIf(dwMilliseconds < 300, 300, 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

Et Pour le tester:

'-------------------------------------------------
'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

Ce code est dans le fichier du Post #18.

 

[patricktoulon]

re
et bien voila !!!!!!! pourquoi faire simple quand on peut faire compliqué

Option Explicit
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
Dim capt$
Dim byebye As Boolean
Dim timerID&
Function msgboxX(Optional message As String = "", Optional style As VbMsgBoxStyle, Optional titre As String, Optional helper = 0, Optional contexte = 0, Optional DelayOfResponse As Long = 3)
    Dim X
    byebye = False: capt = titre
    timerID = SetTimer(0, 0, DelayOfResponse * 1000, AddressOf fermeMessage)
    X = MsgBox(message, style, titre)
    If timerID <> 0 Then KillTimer 0, timerID: timerID = 0:
    If byebye Then X = "timeOut!!"'réponse "timeout!!"
    'ou
    'If byebye Then If timerID <> 0 Then KillTimer 0, timerID: timerID = 0:    'réponse par defaut
    msgboxX = X
End Function

Public Sub fermeMessage()
    byebye = True:
    AppActivate capt
    CreateObject("wscript.shell").SendKeys ("{Enter}")    'choisi "No" automatiquement si vbyesno
End Sub

Sub test()
    Dim rep As String    'VbMsgBoxResult
' msgboxX( [message] , [style+icon+bouton par defaut+fenetre premier plan] , [titre] , [help] , [context] , [delay])
    rep = msgboxX("salut les loulous", vbAbortRetryIgnore + vbDefaultButton3 + vbInformation + vbMsgBoxSetForeground, "testmessage", , , 3)
    MsgBox rep
End Sub

supprimer le else if timerID.... aussi plus la peine

 

[Dudu2]

Et tu n'as pas fait attention à ma remarque à propros du titre vide -> crash sur l'AppActivate !

rep = msgboxX("salut les loulous", vbAbortRetryIgnore + vbDefaultButton3 + vbInformation + vbMsgBoxSetForeground, "", , , 3)

- Soit tu appelles MsgBox SANS le Titre (MsgBox appliquera son défaut: "Microsoft Excel")
Mais alors dans ce cas, il faut bien faire un AppActivate "Microsoft Excel" (un peu lourd tout ça)
- Soit lorsque le titre est vide tu le changes par le défaut "Microsoft Excel" et tu n'as rien à faire car tu appelles MsgBox AVEC le Titre (comme quand il est non nul) et l'AppActivate Titre est OK.

Edit: dans mon code j'ai quand même ramené le minimum duTimer à 100 ms. Sinon ça part en vrille car les rappels de la fonction Time Out sont trop rapides.

 

[patricktoulon]

re
mettons cela au propre
oui c'est vrai j'ai oublié de remettre les arguments en optional
voila on a l'option responsebydefault ou timeout!! a l'appel

'======================================================
'       !! TEMPORISER LE VRAI MSGBOX DE VBA !!
'catégorie boite de dialogue
'Temporisation du vrai msgbox de vba
'Auteurs: Dudu2 et 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 ResponseByDefault As Boolean = False, Optional DelayOfResponse As Long = 3)
    Dim Response$
    MsgBoxTitle = titre: MsgBoxCloseD = False:
    timerID = SetTimer(0, 0, DelayOfResponse * 1000, AddressOf CloseMsgBox)
    Response = MsgBox(message, style, titre)
    If timerID <> 0 Then KillTimer 0, timerID: timerID = 0:
    If MsgBoxCloseD And Not ResponseByDefault Then Response$ = "timeOut!!"
    'réponse "timeout!!" ou le bouton par defaut selon l'argument ResponseByDefault
    msgboxX = Response
End Function

Public Sub CloseMsgBox()
    MsgBoxCloseD = True: AppActivate MsgBoxTitle
    CreateObject("wscript.shell").SendKeys ("{Enter}")    'choisi "No" automatiquement si vbyesno
End Sub

'EXEMPLE D UTILISATION

'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", True, 3)
    MsgBox rep
End Sub

'exemple de simple msgbox d'avertissement

Sub test2()
msgboxX "coucou tout le monde", DelayOfResponse:=2
End Sub

bien entendu rien ne vous empêche de mettre l'icon même sans style

msgboxX "coucou tout lemonde", vbInformation, DelayOfResponse:=2

maintenant c'est clean

 

[Dudu2]

Aux détails près des versions, enfin un vrai MsgBox temporisé !
Je crois que le Monde, que dis-je, l'Univers l'envie à ce Forum excel-download .

 

[eriiic]

Pour rappel pour le demandeur, s'il désire juste arrêter son code sur demande, ici c'est en 3 lignes (4 si demande de confirmation) :

https://www.excel-downloads.com/thr...sgbox-apres-1mn.20048098/page-4#post-20354012

En testant une checkbox.
eric

 

[patricktoulon]

re
bonsoir @eriiiic
pour rappel de ce que le demandeur demande

Hello,
Je souhaiterais faire une macro qui tourne en boucle, mais m'offre régulièrement une porte de sortie.
J'ai donc fait une boucle qui m'ouvre une Msgbox.
Si je clique "yes", il sort de la macro.
Si je clique "No" il déroule la macro et retourne sur la Msgbox.

il y a une différence entre répondre a une question et proposer une autre solution dans un autre principe


@Dudu2 merci tu m'a appris une chose aujourd'hui et pourtant je l'utilisais souvent cet api

 

[patricktoulon]

@Dudu2
je viens de me rendre compte que c'est pas tout a fait çà
le killtimer après la ligne msgbox est opérant du fait que la procédure dans adressof relâche le msgbox par le sendkeys enter
donc attention a l'interprétation du déroulement
sans le msgbox la procédure n'est pas appelée

 

[eriiic]

Je souhaiterais faire une macro qui tourne en boucle, mais m'offre régulièrement une porte de sortie.

La différence c'est que sa porte de sortie sera disponible en permanence sur demande.
On peut enlever les oeillères de temps en temps, élargir un peu le champ des possibles et proposer qq chose auquel il n'avait pas pensé.
Bon, c'est sûr que 3 lignes ça en jette moins que 4 API pour boucher les trous dans la raquette...

 

[Dudu2]

le killtimer après la ligne msgbox est opérant du fait que la procédure dans adressof relâche le msgbox par le sendkeys enter

Exactement ! C'est l'astuce du regroupement.

 

[Dudu2]

Au final, le SendKeys fonctionne pour fermer la fenêtre.
Mais j'aimerais bien fermer cette fenêtre MsgBox rétive lorsque les boutons sont vbYesNo et vbAbortRetryIgnore. Le SendMessage hWnd, WM_CLOSE, 0, 0 ne fonctionne pas et après des heures sur la doc de l'API je ne trouve rien pour forcer la fermeture de cette fenêtre, à part un DestroyWindow (équivalent d'un SendMessage HWnd, WM_NCDESTROY, 0, 0) qui hélas a un très étrange effet de bord en relançant le MsgBox avec une icône critical.

 

[patricktoulon]

re
avec sendkeys vbyesno se ferme aussi chez moi
c'est quoi le hex de WM_NCDESTROY

 

[patricktoulon]

au puré oui tu a raison y a un puré d'effet et après excel plante et redémarre

 

[patricktoulon]

puré j'ai essayé postmessage qui est asynchrone ca plante aussi
j'ai essayé SendMessageTimeoutA ca plante aussi