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]

Un OnTime ne remet rien en cause dans l'organisation des données du classeur !

Peut-être en effet... A tester. Mais pas facile !

 

[Dudu2]

Peut-être que la seule utilisation "safe" du Timer serait de valoriser des données en mémoire (un flag...) ? Aux procédures Excel de l'exploiter.

Encore que dans le MsgBox temporisé, l'action du Timer est de fermer une fenêtre Windows (celle du MsgBox) et je ne pense pas que ça puisse entrer en conflit avec Excel qui n'a aucun traitement sur cette fenêtre, même si elle avait été non Modal, avant qu'un bouton soit cliqué.

Mais bon... suppositions !

 

[patricktoulon]

re
oui avec ton msgbox qui est bloquant forcement pas de souci
pour le moment pas de faille detectée

 

[patricktoulon]

re
@Dudu2 dans ton fichier tu a fait une erreur dans la déclaration sendmessage "as longptr"

 

[Dudu2]

avec ton msgbox qui est bloquant forcement pas de souci

Faudrait faire tourner un script quelques centaines de milliers de fois pour tenter de provoquer la simultanéité d'un Clic bouton et du Timer.

déclaration sendmessage "as longptr"

Corrigé dans le fichier du Post #18.

 

[Dudu2]

A la lecture du code de Patrick, je comprends seulement maintenant le sens du message de Bernard concernant:

MsgBoxTimeOut(ByVal HWnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)

Bon tous ces paramètres, je savais pas, j'ai aussi corrigé ça dans le fichier.

 

[patricktoulon]

re
oui ca fait plusieurs fois débat
perso je sais pas si on est obligé de les mettres vu que l'on s'en sert pas

 

[Dudu2]

Ce qui est sûr c'est que ça marche sans.

 

[patricktoulon]

par contre il y a deux truc que je pige pas
1°
les déclaration vb7 fonctionnent chez moi excel2013 32 bits

2°
j'ai essayé de condenser ton idée et ça ne fonctionne plus

#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
#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
#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)
    TimerID = SetTimer(0, 0, CLng(NbSecondes * 1000), AddressOf fermeMessage)
    x = msgboX(message, style, titre)

    If byebye Then
        msgboxX = "timeOut!!"
    Else
        msgboxX = x
    End If
End Function
Sub fermeMessage()
    If TimerID Then KillTimer 0, TimerID
    TimerID = 0
    byebye = True
    hWnd = FindWindow(vbNullString, MsgBoxWindowTitle)
    Call SendMessage(hWnd, WM_CLOSE, 0, 0)
End Sub

Sub test()
    x = msgboxX("salut les loulous", vbYesNo, "testmessage", , , 5)
msgboX x
End Sub

 

[Dudu2]

Curieux, je n'ai pas reçu la notification de ton message.

VBA7 c'est à partir de Office 2010. Ça s'applique à Excel 32 ou 64 bits.
Le discriminant pour 64 bits est Win64.

Maintenant je m'embête plus, je ne déclare que pour VBA7. Si quelqu'un utilise une version antérieure, c'est simple à recopier et modifier.

Je vais essayer ton code, pour info j'ai pas mal simplifié le code initial, il reste quelques 8 lignes d'instructions pour tout au final:
Edit: Code corrigé pour inclure le SetFocus de patricktoulon sur les messages suivants.

#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
Private Declare PtrSafe Function SetFocus Lib "user32" ( _
                                 ByVal hwnd As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
                                 ByVal lpClassName As String, _
                                 ByVal lpWindowName As String) As LongPtr
#End If

Private MsgBoxWindowTitle As String
Private TimeOutDéclenché As Boolean

'-----------------------
'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
    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
    SetFocus FindWindow(vbNullString, MsgBoxWindowTitle)
    
    'Ferme la fenêtre MsgBox
    Application.SendKeys "{ENTER}"
    
    'Flag Timer déclenché
    TimeOutDéclenché = True
End Sub

 

[Dudu2]

Ok...
En fait il faut arrêter le Timer après le MsgBox.
Dans ton exemple, tu ne l'arrêtes que si il vient à échéance.
Si on clique un bouton, le Timer tourne toujours.

Edit: Autre chose aussi concernant le Titre de la Fenêtre.
D'après mes tests d'avant (à vérifier), si tu donnes un titre vide à la fenêtre, je ne crois pas que le FindWindow va la trouver. Et pour que le MsgBox affiche son titre par défaut ( "Microsoft Excel"), il faut ne pas passer l'argument Titre. C'est pour ça que quand le Titre est de longueur nulle, je le force à "Microsoft Excel" comme ça je me pose pas de question et passe toujours l'argument Titre.

 

[patricktoulon]

Bonsoir Dudu2
oui excuse moi il y avait quelques coquilles dans ma réduction mais ca ne fonctionne pas quand même
et en effet le timer fait son boulot il est bien déclenché mais ne ferme pas le msgbox

#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
#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
#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)
    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()
    If timerID <> 0 Then KillTimer 0, timerID
    timerID = 0
    byebye = True
    hWnd = FindWindow(vbNullString, capt)
    Call SendMessage(hWnd, WM_CLOSE, 0, 0)
End Sub

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

 

[eriiic]

Bonjour à tous,

Pourquoi pas contrôler avec une case à cocher sur feuille plus simplement ?
(je sais, DoEvents prend des ressources, mais on peut ne l'appeler que toutes les x boucles)

Private Sub CommandButton1_Click()
    Feuil1.CheckBox1 = False
    Do
        ' ***** code bidon
        [D4] = [D4] + 1
        [D4] = [D4] Mod 100000
        ' *****
        DoEvents
        If Feuil1.CheckBox1 Then
            Feuil1.CheckBox1 = False
            If MsgBox("Arrêter macro ?", vbYesNo) = vbYes Then Exit Do
        End If
    Loop
    [D4].ClearContents
End Sub

la boucle sans fin n'est que pour l'exemple, mettre le code prévu
eric

 

[Dudu2]

Ce fil ne veut pas mourir, j'adore

Bonsoir eriiiic,
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 du sujet posté par Fab117 et pour lequel il a déjà pas moins de 5 solutions:
- UserForm non Modal
- MsgBoxPerso basé sur UserForm (Modal avec option Timer)
- Shell Popup temporisé (non Modal)
- MessageBoxTimeOut (non Modal)
- UserForm Modal
- MsgBox temporisé (Modal)

Ce serait cool d'ajouter ta solution si tu pouvais montrer comment la mettre en œuvre pour afficher un message temporisé.

 

[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 ...