Microsoft 365 MsgBox affichage et fermeture en 1 seconde

Sub test()
Const Citation = "Magie universelle§De quelques lettres assemblées§Pour dire l'espoir tenace§De milliers d'êtres sur la terre§Qui crient à tous les vents :§Pax, paix, pace, peace, paco ...§§Mais, si l'écho fidèle§Sur un rocher répercute§Un appel pathétique,§L'espoir se heurte aux murs§De la haine et de l'intolérance§Et nous revient impuissant,§Ou bien se perd, angoissé,§Dans le tonnerre des batailles,§Les ruines des villes en guerre,§Ou les déserts des famines§§Pourtant, comme le phénix,§L'espoir renaît plus fort§Car des hommes s'unissent§Et forgent des trompettes§Pour d 'autres Jericho.§§Mathilde LE MOAL  Guingamp (22)"
   MsgBox Replace(Citation, "§", Chr(10)), , "PAIX"
End Sub

Private Sub Worksheet_SelectionChange(ByVal R As Range)
   Dim TSpl() As String, Titre As String, P As Byte
   If Not Intersect(R, Me.[H4]) Is Nothing Then
       TSpl = Split(Me.[H4].Value, vbLf)
       Titre = TSpl(0)
       For P = 0 To UBound(TSpl) - 1: TSpl(P) = TSpl(P + 1): Next P
       ReDim Preserve TSpl(0 To UBound(TSpl) - 1)
       MsgBox Prompt:=Join(TSpl, vbLf), Title:=Titre
       End If
   End Sub

Private Sub Worksheet_SelectionChange(ByVal R As Range)
   Dim TSpl() As String, Titre As String, P As Byte
   If Not Intersect(R, Me.[H4]) Is Nothing Then
       TSpl = Split(Me.[H4].Value, vbLf)
       Titre = TSpl(0)
       For P = 0 To UBound(TSpl) - 2: TSpl(P) = TSpl(P + 2): Next P
       ReDim Preserve TSpl(0 To UBound(TSpl) - 2)
       MsgBox Prompt:=Join(TSpl, vbLf), Title:=Titre
       End If
   End Sub

CreateObject("Wscript.shell").Popup "Le Message", 1, "Le Titre", 0

CreateObject("Wscript.shell").Popup "Le Message", 1, "Le Titre", 0

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

Sub test1()
MsgBoxX "le message", vbOKOnly, "letitre", DelayOfResponse:=2
End Sub

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 = 0)

    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

Sub test2()
Dim x
x = MsgBoxX("le message", vbYesNo, "letitre", DelayOfResponse:=2)
Select Case x
Case vbYes: MsgBox "vous avez repondu oui"
Case vbNo: MsgBox "vous avez repondu non"
End Select
End Sub