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
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 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
VB: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
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