XL 2019 macro qui cherche date sur internet

[pat66]

Bonjour à tous
J'aimerai que la date qui sert de référence pour certaine macros soit une date trouvée sur internet et non celle du pc pour les rigolos qui antidatent leur PC

merci

 

[sylvanu]

Bonjour Patrick,
Un exemple parmi tant d'autres.
Ceci dit, ceux qui peuvent antidater leur PC peuvent très bien faire sauter les verrous de votre VBA !

 

[pat66]

Bonjour Sylvanu

Un grand merci !

oui bien sur, mais c'est une protection de plus qui peut en décourager plus d'un

Pourrais tu me la modifier afin qu'elle s"écrive dans une cellule, ex Feuil1, A1

 

[sylvanu]

Re,
Il suffit de remplacer le MsgBox par l'écriture dans la cellule.

 

[pat66]

Un grand merci pour ta réactivité et tes compétences

je te souhaite de très bonnes fêtes

a bientôt

 

[pat66]

Bonjour
ta macro fonctionne très bien, mais si la personne n'est pas connectée à internet cela me signale une erreur à l'ouverture car la macro ne peux aller chercher la date , est t'il possible de faire en sorte que si l'utilisateur n'est pas connecté, l'action s'annule afin que le classeur s'ouvre sans erreur
merci

 

[sylvanu]

Bonjour Patrick,
J'ai rajouté un on error goto Fin, cela devrait résoudre le problème.
J'ai éssayé et apparament ça parche.
Testez le.

 

[patricktoulon]

bonjour Patrick(les meilleurs ),@sylvanu

perso j'en ferais une fonction et autant aller chercher la donnée sur un site dédié a cette donnée

Function Date_Heure(x As Long)
    Dim Url$
    Url = "http://www.dateaujourdhui.com/"
    Date_Heure = "not connecting!!"
    On Error Resume Next
    With CreateObject("microsoft.XMLHTTP"): .Open "GET", Url, False: .Send
        Select Case x
        Case 1: Date_Heure = Format(Split(Split(.responsetext, "Date actuelle: ")(1), "</p>")(0), "dd/mm/yyyy")
        Case 2: Date_Heure = Format(Split(Split(.responsetext, "Heure exacte: ")(1), "</span>")(0), "HH:MM")
        Case 3: Date_Heure = Split(Split(.responsetext, ". Semaine ")(1), ".</p>")(0)
        End Select
    End With
End Function


Sub test()
    If Not Date_Heure(1) = "not connecting!!" Then
        MsgBox "Date: " & Date_Heure(1)    '1 pour la date
        MsgBox "Heure exacte :" & Date_Heure(2)    '2 pour l'heure
        MsgBox "semaine " & Date_Heure(3)    '3 pour la semaine
    Else
        'tant pis on recup la date du system ou rien comme tu veux
        '....
    End If
End Sub

mais entre nous il y aurais encore beaucoup a faire, du genre les split de split de Chrüterchraft !… c'est bien beau mais !!!!
exemple demain le site change ses phrases et pof!! tu tombe sur "not connecting" car la gestion d'erreur est globale
il serait préférable de travailler le dom document
et aussi de travailler avec l'object XMLHttpRequest. 5 dont on peut gérer le delay et le type d'erreur dans la reponsetext ou tout simplement dans le return
a mediter

 

[pat66]

Bonjour Patrick,
J'ai rajouté un on error goto Fin, cela devrait résoudre le problème.
J'ai éssayé et apparament ça parche.
Testez le.

Bonjour Sylvanu, et merci pour ton aide,
Pourrait tu adapter cette macro de sorte que cette procédure s"exécute automatiquement dès l'ouverture du classeur avec workbook open() et non pas à l 'aide d'un bouton et que la date s'inscrive par exemple dans une zone ou en feuil1 cellule A1 qui servira de référence à ma macro de protection

Merci

 

[pat66]

bonjour Patrick(les meilleurs ),@sylvanu

perso j'en ferais une fonction et autant aller chercher la donnée sur un site dédié a cette donnée

Function Date_Heure(x As Long)
    Dim Url$
    Url = "http://www.dateaujourdhui.com/"
    Date_Heure = "not connecting!!"
    On Error Resume Next
    With CreateObject("microsoft.XMLHTTP"): .Open "GET", Url, False: .Send
        Select Case x
        Case 1: Date_Heure = Format(Split(Split(.responsetext, "Date actuelle: ")(1), "</p>")(0), "dd/mm/yyyy")
        Case 2: Date_Heure = Format(Split(Split(.responsetext, "Heure exacte: ")(1), "</span>")(0), "HH:MM")
        Case 3: Date_Heure = Split(Split(.responsetext, ". Semaine ")(1), ".</p>")(0)
        End Select
    End With
End Function


Sub test()
    If Not Date_Heure(1) = "not connecting!!" Then
        MsgBox "Date: " & Date_Heure(1)    '1 pour la date
        MsgBox "Heure exacte :" & Date_Heure(2)    '2 pour l'heure
        MsgBox "semaine " & Date_Heure(3)    '3 pour la semaine
    Else
        'tant pis on recup la date du system ou rien comme tu veux
        '....
    End If
End Sub

mais entre nous il y aurais encore beaucoup a faire, du genre les split de split de Chrüterchraft !… c'est bien beau mais !!!!
exemple demain le site change ses phrases et pof!! tu tombe sur "not connecting" car la gestion d'erreur est globale
il serait préférable de travailler le dom document
et aussi de travailler avec l'object XMLHttpRequest. 5 dont on peut gérer le delay et le type d'erreur dans la reponsetext ou tout simplement dans le return
a mediter

Salut Pat, intéressante ta solution, pourrait tu m'indiquer comment placer la Function et le sub
car il faut que tout cela soit vérifier automatiquement dès l'ouverture du classeur et que la date récupérée s'inscrive dans une celllule ex Feuil1 , cel1
qui servirait de référence pour ma macro de protection . actuellement voici ce que j'ai dans workbbok open :
Range("dday") = CDate(today)
Dim dsys, dday As Date
dsys = ThisWorkbook.Names("dsys").RefersToRange.Value
dday = Date
If (dsys < dday) Then Annexe (annexe = macro suicid)

qu'en penses tu ?

merci

 

[sylvanu]

Bonjour Les Patricks,
En PJ : A l'ouverture du fichier met la date en A1. Si erreur détectée met en A1 la date système.

 

[patricktoulon]

Bonjour tout les deux

pourquoi utiliser une cellule il n'y en a pas vraiment besoins

Private Sub Workbook_Open()
Dim realDate As Variant, ladate As Date
ladate = Date
realDate = Date_net
If realDate <> ladate Then
If IsDate(realDate) Then MsgBox "Tu me prends pour un haricot toi!!! bye bye!!! ALLEZ ON FERME !!!!!" ':thisworkbook.close'(debloquer vraiment le commentaire pour fermer reellement )
If Not IsDate(realDate) Then MsgBox " bon je ne peux pas controler l'anti datage de ton pc ca passe pour cette fois ci !!! mais verifie ta connection!!!"
End If
End Sub


Function Date_net()
    Dim Url$
    Url = "http://www.dateaujourdhui.com/"
    Date_net = "not connecting!!"
    On Error Resume Next
    With CreateObject("microsoft.XMLHTTP"): .Open "GET", Url, False: .Send
         Date_net = CDate(Format(Split(Split(.responsetext, "Date actuelle: ")(1), "</p>")(0), "dd/mm/yyyy"))
      End With
End Function

LOL

 

[pat66]

Bonsoir Sylvanu

j'ai testé sans connexion donc date système et je ne vois la date dans A1, qu'en penses tu ?

En tout cas, passe un bon réveillon,

 

[pat66]

Patrick,

Because réveillon je testerai ta macro demain, ca à l'air au poil

un grand merci et passe un bon reveillon

 

[sylvanu]

Oups ! Il restait des On error resume en pagaille.
Ca marche maintenant.