SYNCHRONISATION HORRAIRE (HORLOGE ATOMIQUE) AVEC GESTION DE DÉLAIS

Commentaire de CanisLupus le 22/08/2004 18:52:37 administrateur CS

Pas mal, mais recherche sur le site, il y a mieux.
Je ne critique pas l'appel à un serveur américain, m'en fous, un serveur c un serveur. Mais toutes tes manipulations de chaine du style mid(...) et autres if second= .... C ça qui ralentit ton prog.
Va voir du côté des Types utilisateur du style :

Private Type SYSTEMTIME
    wYear        As Integer
    wMonth      As Integer
    wDayOfWeek  As Integer
    wDay            As Integer
    wHour        As Integer
    wMinute      As Integer
    wSecond      As Integer
    wMilliseconds As Integer
End Type

Bonne prog

Commentaire de CanisLupus le 22/08/2004 20:03:54 administrateur CS

Tout ce que je peux dire c que j'utilise le code suivant pour remettre à l'heure mon PC et ça marche ! Ce code vient de vbfrance mais je ne sais  plus qui en est l'auteur, s'il pouvait se manisfester !    

' Programme SYnchronisation de votre PC

' Le serveur NTP écoute sur le port 37
' le client se connecte sur le port 37
' le serveur envoie la date et l'heure sous forme d'un nombre
'  entier de secondes depuis 1900
' le serveur ferme la connexion

Dim sNTP         As String  'trame 32 bits retournée par le serveur SNTP
Dim sngTimeDelay As Single  'temps écoulé entre la connection au serveur
                            'et les données recues.
                            'la correction à apporter est égale
                            'à la moitié de cette valeur


Private Declare Function SetSystemTime Lib "kernel32" _
     (lpSystemTime As SYSTEMTIME) As Long
    
Private Type SYSTEMTIME
    wYear        As Integer
    wMonth      As Integer
    wDayOfWeek  As Integer
    wDay            As Integer
    wHour        As Integer
    wMinute      As Integer
    wSecond      As Integer
    wMilliseconds As Integer
End Type

Sub Form_load()
    Me.Hide
    With Winsock
        .Close
        sNTP = Empty
        '
        ' Nom du serveur de temps NTP.
        ' L'heure suisse même atomique c'est autre chose !
        .RemoteHost = "ntp.metas.ch"
        '
        ' Connection sur le port dédié 37. (RFC 1305, 1361, 2030)
        '
        .RemotePort = 37
        .Connect
    End With
End Sub

Private Sub WinSock_DataArrival(ByVal bytesTotal As Long)
     Dim sData As String

     Call Winsock.GetData(sData, vbString)
     sNTP = sNTP & sData
End Sub
Private Sub WinSock_Connect()
    sngTimeDelay = Timer 'temps écoulé depuis minuit
End Sub
Private Sub WinSock_Close() 'le serveur ferme la connection
     On Error Resume Next

     Do Until Winsock.State = sckClosed
        Winsock.Close
        DoEvents
     Loop

     sngTimeDelay = ((Timer - sngTimeDelay) / 2) 'correction en secondes à apporter entre la connection et la fermeture de connection
     Call SyncClock(sNTP)
End Sub
Private Sub SyncClock(sTemp As String)
     Dim dblNTPTime     As Double   ' réponse temps en secondes écoulées depuis 1900
     Dim UTCDATE         As Date
     Dim LngTimeFrom1990 As Long
     Dim ST             As SYSTEMTIME
    
     sTemp = Trim$(sTemp) ' élimine les espaces à droite et gauche
     If Len(sTemp) <> 4 Then    ' vérifie la longueur de la chaine de retour 4 caractères
        Call MsgBox("le serveur NTP retourne une réponse invalide.", _
                vbCritical, "Réponse invalide")
        Exit Sub
     End If

     ' décodage de la chaine de 4 caractères ACII retournées
     dblNTPTime = Asc(Left$(sTemp, 1)) * 256 ^ 3 + Asc(Mid$(sTemp, 2, 1)) * 256 ^ 2 + _
     Asc(Mid$(sTemp, 3, 1)) * 256 ^ 1 + Asc(Right$(sTemp, 1))
        
     LngTimeFrom1990 = dblNTPTime - 2840140800# 'temps en secondes depuis 1990
    
     ' correction de la date introduite au système
     UTCDATE = DateAdd("s", CDbl(LngTimeFrom1990 + CLng(sngTimeDelay)), #1/1/1990#)

     With ST
        .wYear = Year(UTCDATE)
        .wMonth = Month(UTCDATE)
        .wDay = Day(UTCDATE)
        .wHour = Hour(UTCDATE)
        .wMinute = Minute(UTCDATE)
        .wSecond = Second(UTCDATE)
     End With

     Call SetSystemTime(ST)
     Call MsgBox("Horloge PC synchronisée avec succés.", vbInformation, _
     "Mise à l'heure réussie")

End Sub

Si ça peut te servir......

Bonne prog

Commentaire de CanisLupus le 23/08/2004 20:32:49 administrateur CS

ben, je sais, c pas top mais comme je n'ai pas retrouvé l'adresse ...... cela dit, la source de yannickt est bonne aussi.

Commentaire de bca le 28/10/2006 00:50:34

Lors de l'execution de votre code une erreur apparait
il fallait remplacer tcptime par dans la ligne 10