Pour une solution sans macro, voyez ici.


Il peut y avoir deux type de comptes à rebours :

  • Le premier que l'on va lancer manuellement sur une diapositive, pour un jeu par exemple.
  • Le second qui peut faire un décompte sur plusieurs jours, dans une présentation qui tourne en continu.

Ce sont, bien entendu, deux cas totalement différents. Voici donc deux macros totalement différentes !

Premier cas - Compte à rebours de quelques secondes ou de quelques minutes

Sub compte_a_rebours()
Dim temps As Date
temps = Now()
Dim compte As Integer
compte = 10 'mettre le nombre de secondes ou en minutes
temps = DateAdd("s", compte, temps) 'pour des minutes, mettre "n" à la place de "s"
Do Until temps < Now()
DoEvents
ActivePresentation.Slides(1).Shapes("affichage").TextFrame.TextRange = Format((temps - Now()), "hh:mm:ss")
Loop
End Sub
  • Ajoutez dans votre diapositive une zone de texte que vous nommerez "affichage". C'est dans cette zone que s'affichera le compte à rebours.
  • Prévoyez un objet de la diapositive sur lequel cliquer pour lancer la macro :
    • Sélection de l'objet puis onglet Insertion => groupe Liens => Actions.
    • Cochez Exécuter la macro et sélectionner cette macro.

Lors du diaporama, il vous suffira de cliquer sur l'objet prévu pour déclencher le compte à rebours.

Second cas - Compte à rebours de plusieurs jours dans l'attente d'un événement

Je parle ici d'une présentation qui tourne en boucle et dont le compte à rebours s'affichera sur la première diapositive, par exemple. Il va donc falloir créer une macro événementielle, ce qui n'est pas l'apanage de PowerPoint. Néanmoins, nous avons la chance pour ce cas de disposer d'une macro qui pourra se lancer automatiquement lorsque cette diapositive s'affichera.

La macro suivante s'exécutera à chaque passage de la première diapositive. Elle affichera les jours restants, et avertira le jour j. Quand le jour sera passé, elle ajoute un texte "c'est passé !". Vous pouvez bien entendu mettre vos propres messages.

En réalité il y a deux macro : la macro qui calcule ("compte-a-rebours2") et la macro événementielle qui lance la macro qui calcule.

Comme pour la macro précédente, prévoyez une zone de texte nommée "affichage" qui contiendra les textes et le décompte.

Sub compte_a_rebours2()
Dim madate As Date
Dim compte As Long
'change to suit
madate = "18/06/2021"
compte = DateDiff("d", Now, madate)
Select Case compte
Case Is > 1
ActivePresentation.Slides(1).Shapes("affichage").TextFrame.TextRange = "Encore " & compte & " jours à attendre !"
Case Is = 0
ActivePresentation.Slides(1).Shapes("affichage").TextFrame.TextRange = " C'est le grand jour !"
Case Else
ActivePresentation.Slides(1).Shapes("affichage").TextFrame.TextRange = "c'est passé !"
End Select
End Sub

Sub OnSlideShowPageChange(ByVal pps As SlideShowWindow)
    If pps.View.CurrentShowPosition = pps.Presentation.SlideShowSettings.StartingSlide Then
    Call compte_a_rebours2
    End If
End Sub

Si la diapositive n'est pas la première, vous mettrez le bon numéro dans la macro précédente et vous utiliserez la macro événementielle suivante en remplaçant le chiffre 3 par le numéro de votre diapositive.

Sub OnSlideShowPageChange(ByVal pps As SlideShowWindow)
    If pps.View.CurrentShowPosition = 3 Then
    Call compte_a_rebours2
    End If
End Sub