Compte à rebours qui s'arrête après modification de date du pc

**gnedea** · 01/09/2018, 02h15

salut à tous
Je suis un nouveau en vba
J'ai créé un petit classeur excel 2013 pour calculer les notes de mes élèves .
Je souhaite empecher un utlisateur à utiliser ce classeur s'il modifie la date ou l'heure (en moins ou en plus) de son ordinateur.
Aussi je souhaite par exemple quand la date du pc est modifiée le classeur de ferme aussi tôt.
Malheureusement lorsque je modifie la date le compte a rebours s'arrête automatiquement et le classeur est utilisable.
Quelqu'un pourrait-il m'aider s'il vous plaît?
Voici un petit bout de code que j'utilise:
Dans un module:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Sub Maj_Horloge ( )
Application.Ontime Now + TimeValue
 ("00:00:01"),"Maj_Heure"
End Sub
 
Sub Maj_Heure ( )
Sheets ("Tle").Range ("A21").Value=Now ( )
Maj_Horloge

Dans un ThisWorkbook:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Const DateExpiration As Date = "30/09/2018"
Sub ThisWorkbook_Open ( )
If Date > DateExpiration Then
    GDM.Show
End If
End Sub

**eriiic** · 02/09/2018, 09h03

Bonjour,

Je n'arrive pas à voir comment ton programme peut faire ce que tu as prévu (?)
S'il ouvre ton fichier après avoir modifié la date comment tu le sais ?
eric

**patricktoulon** · 02/09/2018, 09h33

re
si je comprends bien ce que tu cherche a faire
c'est un classeur avec limite de date/heure de fonctionnement
que la date soit modifiée ou pas dans le system?

c'est ca ?
alors en fait je dirais qu'il ne te faut pas mesurer avec les date system mais bien un chrono

a l'ouverture tu memo "1" dans les name par exemple
et avec application ontime tu modifie ce name pendant le temps de fonctionnement toute les heure et avant la fermeture de fichier
un simple test sur la valeur du name 24 par exemple t'indiquera qu'il a fonctionné 24 heures

Invité · 02/09/2018, 09h55

Bonjour,

Si tu veux empêché les tricheur de triturer l'heure prends une horloge web.

https://www.zeitverschiebung.net/fr/...=country&id=FR

**Theze** · 02/09/2018, 10h04

Bonjour,

Comme Robert le propose, récupérer la date et l'heure sur un site internet :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
Sub Test()
 
    Dim T
    Dim LaDate
    Dim http As Object
 
    On Error GoTo Fin
    Set http = CreateObject("Microsoft.XMLHTTP")
 
    http.Open "GET", "https://time.is/fr/UTC/", False, "", ""
    http.send
 
    LaDate = http.GetResponseHeader("Date")
    T = Split(LaDate, " ")
 
    'la date
    Debug.Print CDate(T(1) & " " & T(2) & " " & T(3))
    'l'heure
    Debug.Print CDate(T(4)) + 0.08333333333
 
    Exit Sub
Fin:
    MsgBox "Une erreur est survenue, impossible de relever la date et l'heure !"
 
End Sub

**Theze** · 02/09/2018, 10h11

Ou encore :

Edit : erreur de code

**patricktoulon** · 02/09/2018, 10h25

bien vu robert j'y ai pas pensé sur le coup

j'avais basé mon idée sur le temps de fonctionnemement
module thisworkbook

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub Workbook_Open()
start
End Sub

module standard

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub start()
For Each nom In ThisWorkbook.Names
If nom.Name = "ttime" Then n = True
Next
If n = False Then ThisWorkbook.Names.Add Name:="ttime", RefersToR1C1:="0"
If n = True Then
X = Val(Replace(ThisWorkbook.Names("ttime"), "=", ""))
Application.DisplayAlerts = False
If X >= 3 Then
 MsgBox "ce fichier n'est plus utilisable" Else ThisWorkbook.Save
'ThisWorkbook.Close 
end if 
End If
ThisWorkbook.Save
 Application.OnTime Now + TimeValue("00:01:00"), "decompte"
 
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Sub decompte()
X = Val(Replace(ThisWorkbook.Names("ttime"), "=", ""))
X = X + 1
Application.DisplayAlerts = False
    ActiveWorkbook.Names("ttime").Delete
ThisWorkbook.Names.Add Name:="ttime", RefersToR1C1:=X
If X >= 3 Then MsgBox "ce fichier n'est plus utilisable": ThisWorkbook.Close Else ThisWorkbook.Save
Application.OnTime Now + TimeValue("00:01:00"), "decompte"
Application.DisplayAlerts = True
End Sub

apres 3 minute de fonctionnement walouh walouh
debloquer la ligne dans start

Invité · 02/09/2018, 12h17

En fait on ne se souci plus du fait que utilisateur modifie la date système vue que le temps qu'il consacre à cette manipulation le pénalise d'autant.

On met le code dans un webbroser et on décrémente le chrono à chaque fois que les secondes repasse à la vealeur d'initialisation.

Par exemple on commence à 11:59=> if s=59 then chrono=chrono-1

**gnedea** · 02/09/2018, 15h00

salut à tous
Merci pour votre spontanéité dans vos réponses j'ai deja une macro qui ferme le classeur apres un temps donné d'utilisation (apres 2 jours) .
Ce que je souhaite exactement c'est une macro qui ferme le classeur excel lorsque la date de l'ordinateur est modifiée.
Je m'explique , par exemple l'utilisateur ouvre le classeur et il constate que la durée de validité est de 2 jours et pour utiliser ce classeur en permanance il modifie la date de son ordinateur en le diminuant de plusieurs jours pour augmenter le temps de validité.
Je veux que lorsque la date est modifiée le classeur de ferme avec un message

Invité · 02/09/2018, 15h31

Si tu utilises une horloge web la validité est toujours de deux jours même si la date système est ramené à 1932

**patricktoulon** · 02/09/2018, 18h03

lance ca au workbook.open

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub test()
    Dim Req, jd, date1 As Date, date2 As Date, x&
    Set Req = CreateObject("microsoft.xmlhttp")
    Req.Open "get", "http://www.ladatedujour.com/", False
    Req.send
    With CreateObject("htmlfile")
        .body.innerhtml = Req.responsetext
        jd = Split(.getelementsbytagname("table")(0).getelementsbytagname("H4")(0).innertext, " "): jd = DateValue(jd(1) & "/" & jd(2) & "/" & jd(3))
        For Each nom In ThisWorkbook.Names
            If nom.Name = "jdate" Then n = True
        Next
        If n = False Then
            ThisWorkbook.Names.Add Name:="jdate", RefersToR1C1:=jd
        Else
            date1 = CDate(Replace(ThisWorkbook.Names("jdate"), "=", ""))
            date2 = CDate(jd)
            x = DateDiff("d", date1, date2, vbMonday)
            If date1 <> date2 And x >= 2 Then MsgBox "ce fichier n'est plus utilisable ": ThisWorkbook.Close True
        End If
    End With
End Sub

dans 2 jour le fichier ne sera plus utilisable et s fermera aussi tot
rien empeche cela dit aux petits malins de l'ouvrir avec macro déactivées et de virer cette sub

**gnedea** · 02/09/2018, 18h39

ok je vais essayer.

**gnedea** · 03/09/2018, 09h31

Bonjour
excusez moi encore une fois
S'il vous plaît je voudrais une macro qui vérifie la condition suivante:
Si le compte a rebours s' arrete alors
la cellule A6 de la feuille zaza = zéro
Sous cette forme : If (chrono arreté ) Then Worksheets ("zaza").Range ("A6") = 0
Pouvez vous m'aider?
Si vous avez un exemple cela me conviendra.

Invité · 05/09/2018, 13h54

Bonjour,
avec une horloge web on n'a plus à se soucier de la date système!

Nom : Test.gif
Affichages : 535
Taille : 235,7 Ko

**gnedea** · 05/09/2018, 16h39

Merci pour votre fichier
le problème lorsque je l'utilise on me dit "l'indice n'appartient pas à la sélection" au niveau de la formule de userform1 à la ligne de : r=Replacé (split(split(split(a(2),.... Comment faire?
Est qu'il y a une erreur dans la formule?

Invité · 05/09/2018, 16h56

il n'y a pas de formule???

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 Sub ini()
 
UserForm1.Show
 End Sub
 Public Sub Tick(D As String)
 Dim t As String
Sheets("Config").Range("A1") = D
End Sub

Notes que j'utilise un onglet qui s'appel Config!

Code UserForm :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Private Sub TextBox1_Change()
Tick Format(TextBox1, "yyyy-mm-dd hh:mm:ss")
End Sub
Private Sub Myhwile()
While True
Dim tt As Date
 DoEvents
        Dim ee As String, i As Integer
         ee = WebBrowser1.Document.Body.InnerHtml
        Dim a() As String
         a() = Split(ee, "DIV")
        Dim r As String
        r = Replace(Split(Split(Split(a(2), ">")(1), "<")(0), ",")(1), ".", "") '.(.Replace(".", "")a(2).Split(">")(1).Split("<")(0).Split(",")(1).(
        a = Split(r)
        For i = 0 To 12
            If a(2) = Array("Janvier", "Février", "Mars", "Avr", "Mai", "Juin", "Juil", "Août", "Sept", "Oct", "Nov", "Déc")(i) Then
            TextBox1 = DateSerial(CInt(a(3)), i + 1, a(1)) & " " & Split(Split(Split(ee, "DIV")(4), "<SPAN class=hour>")(1), "<")(0) & ":" & Split(Split(Split(ee, "DIV")(4), "<SPAN class=minute>")(1), "<")(0) & ":" & Split(Split(Split(ee, "DIV")(4), "<SPAN class=second>")(1), "<")(0)
                Exit For
            End If
        Next
Wend
End Sub
Private Sub UserForm_Initialize()
        With Me.WebBrowser1
            .Navigate ("https://www.zeitverschiebung.net/clock-widget-iframe-v2?language=fr&size=medium&timezone=Europe%2FParis")
            Do: DoEvents: Loop While .ReadyState() <> 4 Or .Busy
        End With
        Me.Hide
       Myhwile
 
End Sub

**gnedea** · 06/09/2018, 00h34

bonsoir
J'utilise excel 2013
et l'erreur s'affiche toujours à partir de la 13e ligne du code . pouvez vous vérifier s'il vous plaît car je n'ai pas fais de modification

Invité · 06/09/2018, 07h08

Bonjour,

La vidéo du poste #14 atteste que j'ai fais des tests.

Maintenant j'ai Office 365 si une personne alliant 2013 peut faire un test?

Patrick si tu passe par là regardes stp.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Private Sub TextBox1_Change()
Tick Format(TextBox1, "yyyy-mm-dd hh:mm:ss")
End Sub
Private Sub Myhwile()
While True
Dim tt As Date
 DoEvents
        Dim ee As String, i As Integer
         ee = WebBrowser1.Document.Body.InnerHtml
        Dim a() As String
         a() = Split(ee, "DIV")
        Dim r As String
        r = Replace(Split(Split(Split(a(2), ">")(1), "<")(0), ",")(1), ".", "") 
        a = Split(r)
        For i = 0 To 11
            If a(2) = Array("Janvier", "Février", "Mars", "Avr", "Mai", "Juin", "Juil", "Août", "Sept", "Oct", "Nov", "Déc")(i) Then
            TextBox1 = DateSerial(CInt(a(3)), i + 1, a(1)) & " " & Split(Split(Split(ee, "DIV")(4), "<SPAN class=hour>")(1), "<")(0) & ":" & Split(Split(Split(ee, "DIV")(4), "<SPAN class=minute>")(1), "<")(0) & ":" & Split(Split(Split(ee, "DIV")(4), "<SPAN class=second>")(1), "<")(0)
                Exit For
            End If
        Next
Wend
End Sub
Private Sub UserForm_Initialize()
        With Me.WebBrowser1
            .Navigate ("https://www.zeitverschiebung.net/clock-widget-iframe-v2?language=fr&size=medium&timezone=Europe%2FParis")
            Do: DoEvents: Loop While .ReadyState() <> 4 Or .Busy
        End With
        Me.Hide
       Myhwile
End Sub