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

Fab117

XLDnaute Impliqué
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"
VB:
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

XLDnaute Barbatruc
En désespoir de cause, j'ai fini par utiliser ce fameux DestroyWindow car je n'ai RIEN trouvé, soit pour rendre le bouton Close à la fenêtre MsgBox pour vbYesNo et vbAbortRetryIgnore soit pour forcer la fermeture.

Le DestroyWindow a un effet de bord avec cette fenêtre MsgBox (pour toutes les combinaisons de boutons) c'est de doubler l'affichage du MsgBox sans rendre la main après le 1er affichage.

Donc l'idée c'est à l'échéance du Timer demandé (ex. 2 secondes) qui va fermet le 1er affichage, de relancer le Timer à 10 millisecondes pour tuer le 2ème affichage parasite très rapidement. Et ça marche. Petit problème, ça génère un son système sans conséquence.

Voilà le code (voir la surtout function MsgBoxTimeOut) peut-être à réserver à ces 2 combinaisons de boutons récalcitrantes.
VB:
rivate 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 Function DestroyWindow Lib "user32.dll" ( _
                                 ByVal hWnd As LongPtr) As Long
                               
Private Const WM_CLOSE           As Long = &H10

Private MsgBoxWindowTitle As String
Private TimeOutDéclenché As Boolean
Private TimerID As Long

'-----------------------
'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
    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
    TimerID = 0
   
    'Retour
    If TimeOutDéclenché Then MsgBoxTemporisé = -1 Else MsgBoxTemporisé = RetVal
End Function

'-------------------------------------
'Sub de déclenchement TimeOut du Timer
'-------------------------------------
Private Sub MsgBoxTimeOut()
    Dim hWnd As LongPtr
    Dim ProcessId As Long
    Dim lng As Long
    Static Count As Integer
   
    Count = Count + 1
   
    If TimerID Then KillTimer 0, TimerID
    TimerID = 0
   
    'Kill MsgBox Window (la 1ère ou la 2ème instance)
    hWnd = FindWindow(vbNullString, MsgBoxWindowTitle)
    DestroyWindow hWnd
   
    'Le DestroyWindow provoque un 2ème affichage du MsgBox sans sortir du MsgBox initial
    'Il faut relancer le Timer pour tuer au plus vite cette 2ème instance de MsgBox
    If Count = 1 Then TimerID = SetTimer(0, 0, 10, AddressOf MsgBoxTimeOut) Else Count = 0
   
    'Flag Timer déclenché
    TimeOutDéclenché = True
End Sub


'---------------------
'Test MsgBox temporisé
'---------------------
Sub Test_MsgBoxTemporisé()
    Dim RetVal As Integer
   
    'RetVal = MsgBoxTemporisé("Message d'information pendant 1 seconde et demi", 0, "", 1500)
    'GoSub AfficheRetour
   
    RetVal = MsgBoxTemporisé("Cliquer un bouton avant 2 secondes", vbYesNo, "Temps limité !", 2000)
    GoSub AfficheRetour
   
    Exit Sub
   
AfficheRetour:
    Select Case RetVal
        Case -1
            MsgBox "Time Out"
        Case vbOK
            MsgBox "Bouton <Ok> cliqué."
        Case vbYes
            MsgBox "Bouton <Oui> cliqué."
        Case vbNo
            MsgBox "Bouton <Non> cliqué."
        Case vbCancel
            MsgBox "Bouton <Annuler> cliqué."
        Case Else
            MsgBox "Code retour = " & RetVal
    End Select
    Return
End Sub
 

patricktoulon

XLDnaute Barbatruc
j'ai essayé çà ca plante aussi
SetWindowLongA FindWindowA(vbNullString, MsgBoxTitle), -16, &H94CB0080
SendMessage FindWindowA(vbNullString, MsgBoxTitle), WM_CLOSE, 0, 0

je crois que c'est le timer en adressof qui nous plombe on doit taper à coté
chez moi rien ne fonctionne ça plante au bout du temps du timer excel redemarre
 

Dudu2

XLDnaute Barbatruc
Ah si si, le double Timer sur DestryWindow() est viable, je l'ai bien testé. Simplement c'est plus lourd qu'un simple SendKeys alors ce n'est pas une solution compétitive. De plus ça ré-active Excel si on change d'application durant le Timer (ce que j'essayais d'éviter), donc pareil qu'avec le SendKeys précédé d'un AppActivate.

Il faudrait un super expert de l'API Windows pour déterminer les propriétés spécifiques de cette fenêtre résistante au SendMessage ou PostMessage WM_CLOSE et les modifier.
J'attends le résultat de test essais.
 

patricktoulon

XLDnaute Barbatruc
bonjour Dudu2
ben justement j'ai essayé de rendre le full menu a la fenêtre
mais excel me vire
d'ailleurs même en lecture avec getwindowlongA excel me plante et me vire
donc je pense qu'il y a plus que les menus manquants sur cette fenêtre
je souhaite pas partir dans le hook là on en fini plus :p
je continue mes investigations ;)
 

Discussions similaires

Réponses
7
Affichages
358