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

 

[eriiic]

Bonjour,

Ok tu fais un boucle qu'un bouton peut arrêter. Mais je ne vois pas bien le rapport avec la Validation (bouton "no") automatique d'une Msgbox après 1mn

Ce qu'il veut c'est pouvoir arrêter sa macro sur demande. Pour ça, pas forcément besoin d'une msgbox avec une petite usine à gaz autour.
De plus ça permet de se dispenser de l'arrêt d'1 minute régulier, plus de perte de temps.
Que ça l'intéresse ou que ce soit applicable dans son cas est autre chose. Au moins il a l'info
eric

 

[patricktoulon]

bonjour @Dudu2 , @eriiiic

@Dudu2

@patricktoulon,
Je ne vois pas pourquoi ton code ne fonctionne pas. Mais tu as peut-être une idée ? Et même une solution ?
J'en ai bien une à te proposer ...

va y envoie la sauce car là je pige pas l'idée c'est la tienne j'ai simplement fait une réduction de code

edit:
je mettre un msgbox pour lir le hwnd et il est bien lu c'est l'instruction close qui est inopérante

 

[Dudu2]

Bonjour patricktoulon, eriiiic,

hwnd et il est bien lu c'est l'instruction close qui est inopérante

Tu as parfaitement raison et tu as trouvé LA faille de ce système. Par hasard ?

Parce que MsgBox ne se comporte pas de la même façon avec vbAbortRetryIgnore et vbYesNo et avec les autres combinaisons de boutons.
Avec les 2 premières, c'est une fenêtre sans l'option X de la barre d'outils qui résiste au SendMessage WM_CLOSE. J'ai essayé quelques autres méthodes sans succès. Il faudrait un gros expert de l'API pour régler ça, par exemple pour modifier les propriétés de la fenêtre et la rendre "fermable".

Sinon l'alternative simplissime est de considérer que puisque MsgBox (bloquant ou pas) veut une réponse, c'est de la lui donner. Donc un simple SendKeys "{ENTER}" remplace la séquence savante FindWindow() et SendMessage(). J'ai vérifié que ce SendKeys arrive toujours bien à son destinataire en activant une autre application pendant le délai. La séquence du Timer ne s'exécute que lorsque la fenêtre Excel redevient active.

Les divers fichier et code publiés ont été mis à jour en conséquence.

 

[Dudu2]

J'ai vérifié que ce SendKeys arrive toujours bien à son destinataire en activant une autre application pendant le délai. La séquence du Timer ne s'exécute que lorsque la fenêtre Excel redevient active.

Mais ce n'est pas toujours vrai, ça dépend de l'application activée. Donc c'est une situation qu'il faut gérer. Je vais essayer de coder pour que le SendKeys soit envoyé uniquement si la fenêtre est active.
Ou plus simplement ré-activer la fenêtre Excel avant le SendKeys.

 

[patricktoulon]

re
non chez moi vbAbortRetryIgnore bonnet blanc /blanc bonnet
je vais chercher de ce coté

 

[patricktoulon]

re

soit envoyé uniquement si la fenêtre est active.

SetFocus Declare Function SetFocus Lib "user32" ( _
ByVal hwnd As Long) As Long

avant le send key

 

[patricktoulon]

re
send key OK avec un setfocus en prévoyance

Option Explicit
#If VBA7 Then
    Private 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 PtrSafe Function SetFocus Lib "user32" (ByVal Hwnd As LongPtr) As Long
#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, lParam As Long) As Long
    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
    Private Declare Function SetFocus Lib "user32" (ByVal Hwnd As Long) As Long
#End If

Private Const WM_CLOSE As Integer = &H10
Dim capt$
Dim byebye As Boolean
Dim timerID&
Function msgboxX(message, style, titre, Optional helper, Optional contexte, Optional NbSecondes As Long = 3)
    Dim X
    timerID = SetTimer(0, 0, NbSecondes * 1000, AddressOf fermeMessage)
    byebye = False:    capt = titre
    X = msgboX(message, style, titre)
    If byebye Then
        msgboxX = "timeOut!!"
    Else
        If timerID Then KillTimer 0, timerID
        msgboxX = X
    End If
End Function
Public Sub fermeMessage()
    Dim Hwnd&
    If timerID <> 0 Then KillTimer 0, timerID
    timerID = 0:    byebye = True
    Hwnd = FindWindow(vbNullString, capt)
    SetFocus Hwnd
   CreateObject("wscript.shell").SendKeys ("{right}{Enter}") 'choisi "No" automatiquement
   End Sub

Sub test()
    Dim rep
    rep = msgboxX("salut les loulous", vbYesNo, "testmessage", , , 3)
    msgboX rep
End Sub

 

[patricktoulon]

re
réduction terminée ca se résume a cela pour tout ceux qui sont en vb7

Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 PtrSafe Function SetFocus Lib "user32" (ByVal Hwnd As LongPtr) As Long

Dim capt$
Dim byebye As Boolean
Dim timerID&
Function msgboxX(message, style, titre, Optional helper, Optional contexte, Optional NbSecondes As Long = 3)
    Dim X
    timerID = SetTimer(0, 0, NbSecondes * 1000, AddressOf fermeMessage)
    byebye = False: capt = titre
    X = msgboX(message, style, titre)
    If byebye Then X = "timeOut!!" Else If timerID Then KillTimer 0, timerID
    msgboxX = X
End Function

Public Sub fermeMessage()
    byebye = True: If timerID <> 0 Then KillTimer 0, timerID: timerID = 0:
    SetFocus FindWindow(vbNullString, capt)
    CreateObject("wscript.shell").SendKeys ("{right}{Enter}")    'choisi "No" automatiquement si vbyesno
End Sub

Sub test()
    Dim rep
    rep = msgboxX("salut les loulous", vbYesNo, "testmessage", , , 3)
    msgboX rep
End Sub

 

[patricktoulon]

re
allez celle la va te plaire
on réduit les api a settimer et killtimer
et on peut même récupérer une réponse par défaut parmi celle(s) demandée(s)

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(message As String, style As VbMsgBoxStyle, 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 byebye Then X = "timeOut!!" Else If timerID Then KillTimer 0, timerID    'reponse timeout!!
        'ou
    'reponse par defaut (vbDefaultButton1 ou vbDefaultButton2 ou vbDefaultButton3 ou vbDefaultButton4)selon le style initié
    'If byebye Then If timerID Then KillTimer 0, timerID 'on se contente alors de simplement tuer le timer
    msgboxX = X
End Function

Public Sub fermeMessage()
    byebye = True: If timerID <> 0 Then KillTimer 0, timerID: timerID = 0:
     CreateObject("wscript.shell").SendKeys ("{Enter}")    'tape  automatiquement dans le bouton par défaut  initié dans l'appel
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

et encore je kill le timer alors qu'il est deja killé
allez on reduit encore

Function msgboxX(message As String, style As VbMsgBoxStyle, 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 byebye Then X = "timeOut!!"    'reponse timeout!! supprimer cette ligne pour obtenir la reponse par defaut
    msgboxX = X
End Function

 

[Dudu2]

J'ai ajouté le SetFocus (que tu as retiré de ta dernière version) avant le SendKeys mais il ne change pas le problème lors de l'activation d'une autre application. Par exemple si je passe sur Thunderbird durant la temporisation il lance la page Web du lien sélectionné dans le message affiché. Le SendKeys arrive sur ThunderBird.

Dans ton dernier post, dans la fonction msgboxX() tu as éliminé le KillTimer().
Mais si il a clic bouton, tu n'arrêtes plus le Timer.
Si tu veux 1 seul KillTimer, il faut le mettre après le MsgBox et le retirer du fermeMessage().
Ça ne pose pas de problème même avec un Timer de 1 milliseconde, j'ai testé.

 

[patricktoulon]

Mais si il a clic bouton, tu n'arrêtes plus le Timer
a oui bien vu

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 byebye Then X = "timeOut!!" Else If timerID <> 0 Then KillTimer 0, timerID: timerID = 0: 'réponse "timeout!!"
    'ou
    'If byebye Then If timerID <> 0 Then KillTimer 0, timerID: timerID = 0:    'réponse par defaut
    msgboxX = X
End Function

par contre le faire juste après je pige pas
pour le changement de fenêtre voir d'application ca se complique
quand on sait par exemple que Word malgré et contre tous prend quand meme le focus a l'ouverture
et d'autre fenêtre aussi

 

[Dudu2]

Pour vérifier que le SendKeys est bien envoyé au MsgBox, dans la fonction appelée au Time Out, il faut tester:
If FindWindow(vbNullString, MsgBoxWindowTitle) <> GetActiveWindow Then Exit Sub

J'ai mis Exit Sub mais le mieux serait de relancer un Timer de 1 seconde pour attendre que l'utilisateur revienne sur Excel / MsgBox. Je ferai ça après déjeuner

 

[patricktoulon]

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

 

[Dudu2]

parcontre le faire juste après je pige pas

Ben tu fais ça:

Function MsgBoxTemporisé(Texte As String, Boutons As Integer, Titre As String, TimerMilliSecondes As Long) As Integer
    Dim RetVal As Integer
    Dim TimerID As Long
    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
   
    'Retour
    If TimeOutDéclenché Then MsgBoxTemporisé = -1 Else MsgBoxTemporisé = RetVal
End Function

'-------------------------------------
'Sub de déclenchement TimeOut du Timer
'-------------------------------------
Private Sub MsgBoxTimeOut(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
   
    'Pour assurer que le SendKeys ne soit pas envoyé à une autre application
    If FindWindow(vbNullString, MsgBoxWindowTitle) <> GetActiveWindow Then Exit Sub
   
    'Ferme la fenêtre MsgBox
    SendKeys "{ENTER}"
   
    'Flag Timer déclenché
    TimeOutDéclenché = True
End Sub

 

[patricktoulon]

tu es en train de me dire qu'un timer enclenché puis killé tout de suite continue jusqu'a son delay initié puis ne se répete pas c'est bien çà

edit: OK vérifié CA JE SAVAIS PAS

par contre pour le on top de la fenêtre nada 3 api inopérantes
il me reste encore a tester setwindowpos