Impossible de stopper Application.OnTime

Bonjour,

Je souhaite faire apparaître un message lorsque les utilisateurs d’un fichier partagé oublient de le fermer, si il est ouvert en modification.

Tout va bien pour le déclenchement du message toutes les xx secondes (30 dans l’exemple). Par contre, la macro ne s’arrête pas à la fermeture du fichier, et il ré-ouvre le fichier systématiquement.

J’ai lu dans les précédents échanges qu’il s’agit certainement d’un problème de définition du temps, mais ça dépasse mes connaissances...

Voilà mes macros :

Workbook

Private Sub Workbook_Open()
Call Reminder
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnTime LastReminder, "Reminder1", , False
'(egalement essayé : Application.OnTime LastReminder, "Reminder1", False)
End Sub

Module :

Sub Reminder()
Dim LastReminder As Variant
LastReminder = Now() + TimeValue("00:00:30")
Application.OnTime LastReminder, "Reminder1"
End Sub

Sub Reminder1()
If ThisWorkbook.ReadOnly = False Then
Dim Msg, Style, Title, Response
Msg = "You have the xxxxxxx opened for more than 30secondes. Remember to close it if you don't need it !"    ' Define message.
Style = vbCritical + vbApplicationModal    ' Define buttons.
Title = "Reminder"    ' Define title.
Response = MsgBox(Msg, Style, Title)
Call Reminder
Else
Call Reminder
End If
End Sub

Merci pour votre aide et vos conseils

Bonsoir

Dans le code Beforeclose, essayez -->

Application.OnTime LastReminder, "Reminder", , False

Crdlt

Merci Dan,

Ca me donne un RunTime error '1004' a la fermeture.

Ca ne vient pas du fait que "Application.OnTime LastReminder, "Reminder", False" n'existe pas. C'est Reminder1 qui est programmé à se lancer

Re

essayez ceci :

Application.OnTime LastReminder, "Reminder", False

Sinon je ne vois pas le pourquoi du if dans votre code Remider car que le classeur soit en read only ou pas vous relancer la code Reminder

Il me semble que ceci donne la même chose

Sub Reminder1()
Dim Msg, Style, Title, Response
Msg = "You have the xxxxxxx opened for more than 30secondes. Remember to close it if you don't need it !"    ' Define message.
Style = vbCritical + vbApplicationModal    ' Define buttons.
Title = "Reminder"    ' Define title.
Response = MsgBox(Msg, Style, Title)
Call Reminder
End Sub

Crdlt

J'ai ajouté un If, car je souhaite que le message n’apparaisse que pour celui qui a le fichier ouvert en écriture , et pas pour ceux qui l'ont en lecture seule. Cependant comme il est possible de le passer en écriture après le premier passage de la macro (Read Only by default with button Edit Anyway) , je souhaite qu'il vérifie à nouveau.

C'est pour cela que dans les 2 cas, la macro rappelle la macro "Reminder"

Ma macro était initialement écrite comme celle que vous proposez (le If a été un rajout qui fonctionne bien)

J'ai le problème de réouverture du fichier avec et sans le If

Bonjour,

Si vous mettez l'instruction comme je vous l'ai donnée dans mon post précédent (à 5h45) cela fonctionne.

Avez-vous testé ?

Cordialement

Bonjour,

Dim temps
Sub majHeure()
 ThisWorkbook.Sheets("feuil1").[A1] = Now
 temps = Now + TimeValue("00:00:1")
 Application.OnTime temps, "majHeure"
End Sub

Sub auto_open()
   majHeure
End Sub

Sub auto_close()
 On Error Resume Next
 Application.OnTime temps, Procedure:="majHeure", Schedule:=False
End Sub

Boisgontier

Bonjour Dan

Ca va me rendre fou...

Je viens de faire le test en écrivant ce que vous avez proposé. Et la j’ai un comportement étrange: tout fonctionne comme voulu si ce fichier est le seul à être ouvert ... par contre si un autre fichier avec des macros également est ouvert, alors le fichier se réouvre.

Merci encore pour votre aide

Cdlt

Bonjour,

Il ne faut pas oublier:

Sub auto_close()

On Error Resume Next

Application.OnTime temps, Procedure:="majHeure", Schedule:=False

End Sub

Boisgontier

Re

Ca va me rendre fou...

Je viens de faire le test en écrivant ce que vous avez proposé. Et la j’ai un comportement étrange: tout fonctionne comme voulu si ce fichier est le seul à être ouvert ... par contre si un autre fichier avec des macros également est ouvert, alors le fichier se réouvre.

Dans le module où se trouve les deux codes Reminder et Reminder1, mettez ceci tout en haut du module -->

Option Private Module

Crdlt

Dan

Malheureusement même avec l’option Private Module au début du module, le fichier continue de s’ouvrir lorsqu’un autre fichier est ouvert

Re

Votre code ci-dessous est bien comme ceci ?

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On error resume next
Application.OnTime LastReminder, "Reminder1", False
End Sub

Attention, une virgule avant FALSE

Ce code doit être placé dans Thisworbook

Crdlt

Bonjour,

Voilà ou j'en suis , et malheureusement le problème est toujours présent - Mon fichier se ré-ouvre systématique lorsqu'un autre fichier excel est ouvert lors de la fermeture du premier.

Module

Option Private Module

Sub Reminder()

Dim LastReminder As Variant

LastReminder = Now() + TimeValue("00:00:30")

Application.OnTime LastReminder, "Reminder1"

End Sub

Sub Reminder1()

Dim Msg, Style, Title, Response

Msg = "You have the xxxxx for more than 5 minutes. Remember to close it if you don't need it !" ' Define message.

Style = vbCritical + vbApplicationModal ' Define buttons.

Title = "Reminder" ' Define title.

Response = MsgBox(Msg, Style, Title)

Call Reminder

End Sub

ThisWorkbook

Private Sub Workbook_Open()

Call Reminder

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

On Error Resume Next

Application.OnTime LastReminder, "Reminder1", False

' idem avec: Application.OnTime LastReminder, "Reminder", False

End Sub

Merci encore pour votre patience et votre aide

Re

Effectivement.

Je pense que cela est dû au fait que Application qui considère non pas le fichier mais bien excel. D'où si l'événement est déclenché et que plusieurs fichiers sont ouverts, le code ne termine pas à la fermeture du fichier dans lequel se trouve le code Application.ontime.

Le mieux serait d'utiliser le timer sous windows (API windows) et utiliser les instructions settimer pour démarrer et Killtimer pour arrêter.

Cordialement

Edit : A verifier mais je lis que Settimer ne semble pas fonctionner avec excel 2016