Microsoft 365 TIMER (comptage ou décomptage) à l'ouverture du classeur

Michest

XLDnaute Occasionnel
Bonjour à tous,

Je sollicite votre aide pour la réalisation d'un compteur (timer) soit en mode comptage 00:00:01 ... ou bien décomptage 00:04:59 ... qui se déclenche à l'ouverture du classeur ouvert et qui fermera automatiquement le classeur par rapport au temps de paramétrage du timer. (exemple 5mn)

Ceci est lié au partage d'un classeur sur un serveur et parfois le fichier ouvert n'est pas refermé et donc impossible à l'utiliser pour les autres utilisateurs.

Un visuel du timer serait un plus avec éventuellement un avertissement de fermeture 1mn avant la fin du temps programmé.(exemple une couleur)


Merci à vous,
 
Solution
re
bon allez tiens
et la prochaine fois ne mélange pas des sujets ,même si c'est pour le même classeur
ta question intéresse d'autres personnes plus ca reste clair mieux c'est
donc pour ta totale
VB:
Dim timerstart
Dim rupturcycle As Boolean
Const durée_max As String = "00:05:00"    'Adapter la durée souhaitée

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    rupturcycle = True
    ThisWorkbook.Save
End Sub

Private Sub Workbook_Open()
    timerstart = TimeValue(Now)
    lookinstatusbar
End Sub

Sub lookinstatusbar()
    Dim heure1, x, y
    If Not rupturcycle Then
        heure1 = TimeValue(Now)
        x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")...

sylvanu

XLDnaute Barbatruc
Supporter XLD
Dans le code que vous avez donné, nulle part je ne vois Sub Compteur() . Où avez vous implémenté cette macro ?

Ensuite le problème vient peut être du fait que vous avez un tableau structuré nommé Compteur, il se mélange peut être un peu les pinceaux.

C'est pour cela qu'un PJ est toujours la bienvenue, le contexte est aussi important que le code.
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Comme dit au post #16 c'est le nom Compteur qui lui plait pas, en changeant par CompteurTemps ça marche.
Il se mélange les pinceaux entre le nom de la sub et le nom du tableau structuré.
NB : Dans la PJ j'ai supprimé une grosse partie de Workbook_Open car cela générait plein d'erreur due aux protections, mais rien à voir avec notre pb.
vérifiez la PJ telle qu'elle, j'ai remis le temps à 15s pour le test.
Si ça marche, dans votre fichier rebaptisez simplement tous les Compteur par CompteurTemps , il doit y en avoir 4 en tout, un dans Thisworkbook et 3 dans module2 que j'ai rebaptisé CLK dans ma PJ.
 

Pièces jointes

  • FichierTEST.xlsm
    132.1 KB · Affichages: 7

Michest

XLDnaute Occasionnel
Comme dit au post #16 c'est le nom Compteur qui lui plait pas, en changeant par CompteurTemps ça marche.
Il se mélange les pinceaux entre le nom de la sub et le nom du tableau structuré.
NB : Dans la PJ j'ai supprimé une grosse partie de Workbook_Open car cela générait plein d'erreur due aux protections, mais rien à voir avec notre pb.
vérifiez la PJ telle qu'elle, j'ai remis le temps à 15s pour le test.
Si ça marche, dans votre fichier rebaptisez simplement tous les Compteur par CompteurTemps , il doit y en avoir 4 en tout, un dans Thisworkbook et 3 dans module2 que j'ai rebaptisé CLK dans ma PJ.
Ok merci je vérifie tout ça.
 

Michest

XLDnaute Occasionnel
Re,

Le compteur (timer) fonctionne nickel par contre dans la partie Workbook_Open que tu as épuré ceci me cause le problème suivant
1615823057822.png


En mode Admin je n'ai plus aucun de mes onglets de gestion du classeur.
 

patricktoulon

XLDnaute Barbatruc
bonjour
un exemple pour le fun
mise a jour de la statusbar tout les 5 secondes départ durée écoulée et temps restant sub de fermeture déclenchée a la fin
VB:
Dim timerstart
Const durée_max As String = "00:05:00" 'Adapter la durée souhaitée
Private Sub Workbook_Open()
    timerstart = TimeValue(Now)
    lookinstatusbar
End Sub

Sub lookinstatusbar()
    Dim heure1, x, y
    heure1 = TimeValue(Now)
    x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")
    minute_max = TimeValue(durée_max)
    y = TimeValue(Application.Text(minute_max - TimeValue(x), "[hh]:mm:ss"))
    If TimeValue(y) < TimeValue("00:01:01") Then mess = "  Attention fermeture dans moins d'une minute !!!": Beep Else mess = "  il reste plus que :  "
    If y = 0 Then fermeture: Exit Sub
    DoEvents
    Application.StatusBar = "------heure d'ouverture fichier : " & timerstart & "    temps passé:  " & x & mess & y
    Application.OnTime Now + 0.00005, "ThisWorkbook.lookinstatusbar"
End Sub

Sub fermeture()
    MsgBox "c'est ici que tu met ton code de fermeture"
End Sub
 

Michest

XLDnaute Occasionnel
bonjour
un exemple pour le fun
mise a jour de la statusbar tout les 5 secondes départ durée écoulée et temps restant sub de fermeture déclenchée a la fin
VB:
Dim timerstart
Const durée_max As String = "00:05:00" 'Adapter la durée souhaitée
Private Sub Workbook_Open()
    timerstart = TimeValue(Now)
    lookinstatusbar
End Sub

Sub lookinstatusbar()
    Dim heure1, x, y
    heure1 = TimeValue(Now)
    x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")
    minute_max = TimeValue(durée_max)
    y = TimeValue(Application.Text(minute_max - TimeValue(x), "[hh]:mm:ss"))
    If TimeValue(y) < TimeValue("00:01:01") Then mess = "  Attention fermeture dans moins d'une minute !!!": Beep Else mess = "  il reste plus que :  "
    If y = 0 Then fermeture: Exit Sub
    DoEvents
    Application.StatusBar = "------heure d'ouverture fichier : " & timerstart & "    temps passé:  " & x & mess & y
    Application.OnTime Now + 0.00005, "ThisWorkbook.lookinstatusbar"
End Sub

Sub fermeture()
    MsgBox "c'est ici que tu met ton code de fermeture"
End Sub

bonjour
un exemple pour le fun
mise a jour de la statusbar tout les 5 secondes départ durée écoulée et temps restant sub de fermeture déclenchée a la fin
VB:
Dim timerstart
Const durée_max As String = "00:05:00" 'Adapter la durée souhaitée
Private Sub Workbook_Open()
    timerstart = TimeValue(Now)
    lookinstatusbar
End Sub

Sub lookinstatusbar()
    Dim heure1, x, y
    heure1 = TimeValue(Now)
    x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")
    minute_max = TimeValue(durée_max)
    y = TimeValue(Application.Text(minute_max - TimeValue(x), "[hh]:mm:ss"))
    If TimeValue(y) < TimeValue("00:01:01") Then mess = "  Attention fermeture dans moins d'une minute !!!": Beep Else mess = "  il reste plus que :  "
    If y = 0 Then fermeture: Exit Sub
    DoEvents
    Application.StatusBar = "------heure d'ouverture fichier : " & timerstart & "    temps passé:  " & x & mess & y
    Application.OnTime Now + 0.00005, "ThisWorkbook.lookinstatusbar"
End Sub

Sub fermeture()
    MsgBox "c'est ici que tu met ton code de fermeture"
End Sub
Bonjour
J'ai appliqué le code dans mon projet nickel et sympa.
Par contre si je veux quitter le classeur avant la fin du timer en passant par la croix en haut à droite avec sauvegarde j'ai appliqué

ActiveWorkbook.Close True 'Enregistrement par défaut
dans
Private Sub Workbook_BeforeClose(Cancel As Boolean)

et il ferme le classeur mais j'ai ce message
1615829538759.png


puis
1615829590658.png

Je n'arrive pas à sortir
 

patricktoulon

XLDnaute Barbatruc
ben tu n'a qua prevoir de rmpre le cycle tout simplement
avec (par exemple )une variable globale boolean comme condition
VB:
Dim timerstart
Dim rupturcycle As Boolean
Const durée_max As String = "00:05:00" 'Adapter la durée souhaitée

Private Sub Workbook_BeforeClose(Cancel As Boolean)
rupturcycle = True

End Sub

Private Sub Workbook_Open()
    timerstart = TimeValue(Now)
    lookinstatusbar
End Sub

Sub lookinstatusbar()
    Dim heure1, x, y
If Not rupturcycle Then
heure1 = TimeValue(Now)
    x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")
    minute_max = TimeValue(durée_max)
    y = TimeValue(Application.Text(minute_max - TimeValue(x), "[hh]:mm:ss"))
    If TimeValue(y) < TimeValue("00:01:01") Then mess = "  Attention fermeture dans moins d'une minute !!!": Beep Else mess = "  il reste plus que :  "
    If y = 0 Then fermeture: Exit Sub
    DoEvents
    Application.StatusBar = "------heure d'ouverture fichier : " & timerstart & "    temps passé:  " & x & mess & y
    Application.OnTime Now + 0.00005, "ThisWorkbook.lookinstatusbar"
End If
End Sub

Sub fermeture()
    MsgBox "c'est ici que tu met ton code de fermeture"
End Sub
et voila ;)
par contre je ne sais pas ce que ce c'est ce fichier install je sais pas quoi
tu a du installer une cochonnerie
 

Michest

XLDnaute Occasionnel
Re,

Très bien sauf qu'une sauvegarde par défaut juste avant de quitter soit par le timer soit par la croix en haut à droite aurait été parfait car dans mon fichier les cellules sont protégées en écriture donc protégées sauf 2 formulaires 1 pour d'éventuels avis et 1 autre pour demande de mise à jour.
Merci à toi
 

patricktoulon

XLDnaute Barbatruc
re
bon allez tiens
et la prochaine fois ne mélange pas des sujets ,même si c'est pour le même classeur
ta question intéresse d'autres personnes plus ca reste clair mieux c'est
donc pour ta totale
VB:
Dim timerstart
Dim rupturcycle As Boolean
Const durée_max As String = "00:05:00"    'Adapter la durée souhaitée

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    rupturcycle = True
    ThisWorkbook.Save
End Sub

Private Sub Workbook_Open()
    timerstart = TimeValue(Now)
    lookinstatusbar
End Sub

Sub lookinstatusbar()
    Dim heure1, x, y
    If Not rupturcycle Then
        heure1 = TimeValue(Now)
        x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")
        minute_max = TimeValue(durée_max)
        y = TimeValue(Application.Text(minute_max - TimeValue(x), "[hh]:mm:ss"))
        If TimeValue(y) < TimeValue("00:01:01") Then mess = "  Attention fermeture dans moins d'une minute !!!": Beep Else mess = "  il reste plus que :  "
        If y = 0 Then fermeture: Exit Sub
        DoEvents
        Application.StatusBar = "------heure d'ouverture fichier : " & timerstart & "    temps passé:  " & x & mess & y
        Application.OnTime Now + 0.00005, "ThisWorkbook.lookinstatusbar"
    End If
End Sub

Sub fermeture()
    rupturcycle = True
    ThisWorkbook.Save
    If Workbooks.Count = 1 Then Application.Quit Else ThisWorkbook.Close
End Sub
et tu n'aura pas de soucis ;)
 

patricktoulon

XLDnaute Barbatruc
bizarrement je vois pas le rapport mais si il y a plusieurs classeurs d'ouverts il y a une erreur encore
du coup on shunte l'erreur qui peut eventuellement se produire à la fin
VB:
Dim timerstart
Dim rupturcycle As Boolean
Const durée_max As String = "00:05:00"    'Adapter la durée souhaitée

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    rupturcycle = True
    ThisWorkbook.Save
End Sub

Private Sub Workbook_Open()
    timerstart = TimeValue(Now)
    lookinstatusbar
End Sub

Sub lookinstatusbar()
    Dim heure1, x, y
   On Error Resume Next
   If Not rupturcycle Then
        heure1 = TimeValue(Now)
        x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")
        minute_max = TimeValue(durée_max)
        y = TimeValue(Application.Text(minute_max - TimeValue(x), "[hh]:mm:ss"))
        If TimeValue(y) < TimeValue("00:01:01") Then mess = "  Attention fermeture dans moins d'une minute !!!": Beep Else mess = "  il reste plus que :  "
        If y = 0 Then fermeture: Exit Sub
        DoEvents
        Application.StatusBar = "------heure d'ouverture fichier : " & timerstart & "    temps passé:  " & x & mess & y
        Application.OnTime Now + 0.00005, "ThisWorkbook.lookinstatusbar"
    End If
End Sub

Sub fermeture()
    rupturcycle = True
    ThisWorkbook.Save
    If Workbooks.Count = 1 Then Application.Quit Else ThisWorkbook.Close
End Sub
j'ai testé ca match ;)
 

Michest

XLDnaute Occasionnel
re
bon allez tiens
et la prochaine fois ne mélange pas des sujets ,même si c'est pour le même classeur
ta question intéresse d'autres personnes plus ca reste clair mieux c'est
donc pour ta totale
VB:
Dim timerstart
Dim rupturcycle As Boolean
Const durée_max As String = "00:05:00"    'Adapter la durée souhaitée

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    rupturcycle = True
    ThisWorkbook.Save
End Sub

Private Sub Workbook_Open()
    timerstart = TimeValue(Now)
    lookinstatusbar
End Sub

Sub lookinstatusbar()
    Dim heure1, x, y
    If Not rupturcycle Then
        heure1 = TimeValue(Now)
        x = Application.Text(heure1 - timerstart, "[hh]:mm:ss")
        minute_max = TimeValue(durée_max)
        y = TimeValue(Application.Text(minute_max - TimeValue(x), "[hh]:mm:ss"))
        If TimeValue(y) < TimeValue("00:01:01") Then mess = "  Attention fermeture dans moins d'une minute !!!": Beep Else mess = "  il reste plus que :  "
        If y = 0 Then fermeture: Exit Sub
        DoEvents
        Application.StatusBar = "------heure d'ouverture fichier : " & timerstart & "    temps passé:  " & x & mess & y
        Application.OnTime Now + 0.00005, "ThisWorkbook.lookinstatusbar"
    End If
End Sub

Sub fermeture()
    rupturcycle = True
    ThisWorkbook.Save
    If Workbooks.Count = 1 Then Application.Quit Else ThisWorkbook.Close
End Sub
et tu n'aura pas de soucis ;)
MERCI
 
Haut Bas