Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0728: Die aktuelle Internetzeit auslesen II

VB 5/6-Tipp 0728: Die aktuelle Internetzeit auslesen II

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: FileTimeToLocalFileTime, FileTimeToSystemTime, HttpOpenRequestA (HttpOpenRequest), HttpQueryInfoA (HttpQueryInfo), HttpSendRequestA (HttpSendRequest), InternetCloseHandle, InternetConnectA (InternetConnect), InternetOpenA (InternetOpen), InternetTimeFromSystemTime, InternetTimeToSystemTime, SetSystemTime, SystemTimeToFileTime

Download: Download des Beispielprojektes [5,07 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei InetTime.vbp -------------
'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Schaltfläche "cmdSyncWithInetTime"
' Steuerelement: Schaltfläche "cmdGetINetTime"
' Steuerelement: Beschriftungsfeld "lblStatus"
' Steuerelement: Beschriftungsfeld "lblSystem"
' Steuerelement: Beschriftungsfeld "lblLocal"
' Steuerelement: Beschriftungsfeld "lblGMT"
' Steuerelement: Beschriftungsfeld "lblInf" (Index von 0 bis 2)
Option Explicit

' Dadurch das die Internetzeit im RFC1123 Format vorliegt, kann hier nur
' eine sekundengenaue Synchronisation mit der Systemzeit vorgenommen
' werden bzw. die Internetzeit kann nur sekundengenau ermittelt werden.
' Millisekundengenaue synchronisation ist mit diesem Beispiel nicht möglich.

' Host, von dem die Zeitabfrage erfolgen soll.
' Praktisch kann hier jede verfügbare Internetadresse angegeben werden.
Private Const InetHost As String = "www.activevb.de"

Private Sub cmdGetINetTime_Click()

    Dim strINetTime As String
    Dim strLocalTime As String
    Dim strGmtTime As String
    Dim lngDiffSec As Long
    
    ' Statustext
    lblStatus.ForeColor = vbBlue
    lblStatus.Caption = "Internetzeit holen"
    
    DoEvents
    
    ' Internetzeit im RFC1123 Format vom Host ermitteln
    strINetTime = GetINetTime(InetHost)
    
    ' konnte eine Zeitangabe ausgelesen werden
    If Len(strINetTime) > 0 Then
    
        ' RFC1123 Format in das Date Format konvertieren
        strGmtTime = INetTimeToSystemTime(strINetTime)
        
        ' RFC1123 Format in das Date Format (Lokal) konvertieren
        strLocalTime = INetTimeToLocalTime(strINetTime)
        
        ' Differenz in Sekunden zwischen Lokaler- und Systemzeit
        lngDiffSec = CLng(DateDiff("s", CDate(strLocalTime), Now))
        
        ' Ausgabe der Zeiten
        lblGMT.Caption = strGmtTime
        lblLocal.Caption = strLocalTime
        lblSystem.Caption = Now
        
        ' Statustext
        lblStatus.ForeColor = vbBlack
        
        lblStatus.Caption = "Die Differenz zu Ihrer Systemzeit beträgt " & _
            "ca. " & CStr(Abs(lngDiffSec)) & " Sekunde(n)."
            
    Else
    
        ' wenn keine Zeitangabe ermittelt werden konnte
        ' Statustext
        lblStatus.ForeColor = vbRed
        
        lblStatus.Caption = "Die Internetzeit konnte nicht ermittelt " & _
            "werden bzw. " & vbNewLine & " die Internetadresse '" & InetHost _
            & "' war nicht erreichbar."
            
    End If
    
End Sub

Private Sub cmdSyncWithInetTime_Click()

    Dim strINetTime As String
    Dim strLocalTime As String
    Dim strGmtTime As String
    
    ' Statustext
    lblStatus.ForeColor = vbBlue
    lblStatus.Caption = "Internetzeit holen"
    
    DoEvents
    
    ' Internetzeit im RFC1123 Format vom Host ermitteln
    strINetTime = GetINetTime(InetHost)
    
    ' konnte eine Zeitangabe ausgelesen werden
    If Len(strINetTime) > 0 Then
    
        ' RFC1123 Format in das Date Format konvertieren
        strGmtTime = INetTimeToSystemTime(strINetTime)
        
        ' RFC1123 Format in das Date Format (Lokal) konvertieren
        strLocalTime = INetTimeToLocalTime(strINetTime)
        
        ' Systemzeit setzen. Hier muss die GMT-Zeit verwendet
        ' werden. Intern wird dann automatisch die Lokale-Zeit
        ' verwendet.
        If SyncSystemTime(CDate(strGmtTime)) Then
        
            ' Statustext wenn erfolgreich
            lblStatus.ForeColor = vbBlack
            lblStatus.Caption = "Die Synchronisierung war erfolgreich."
            
        Else
        
            ' Statustext wenn nicht erfolgreich
            lblStatus.ForeColor = vbRed
            lblStatus.Caption = "Die Synchronisierung war nicht erfolgreich."
            
        End If
        
        ' Ausgabe der Zeiten
        lblGMT.Caption = strGmtTime
        lblLocal.Caption = strLocalTime
        lblSystem.Caption = Now
        
    Else
    
        ' wenn keine Zeitangabe ermittelt werden konnte
        ' Statustext
        lblStatus.ForeColor = vbRed
        
        lblStatus.Caption = "Die Internetzeit konnte nicht ermittelt " & _
            "werden bzw. " & vbNewLine & " die Internetadresse '" & InetHost _
            & "' war nicht erreichbar."
            
    End If
    
End Sub
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'--------- Anfang Modul "modMain" alias modMain.bas ---------
Option Explicit

' ----==== Const ====----
Private Const HTTP_QUERY_DATE As Long = 9

Private Const INTERNET_DEFAULT_HTTP_PORT As Long = 80
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
Private Const INTERNET_RFC1123_FORMAT As Long = 0
Private Const INTERNET_RFC1123_BUFSIZE As Long = 30
Private Const INTERNET_SERVICE_HTTP As Long = 3

' ----==== Type ====----
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

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

' ----==== KERNEL32 Deklarationen ====----
Private Declare Function SetSystemTime Lib "kernel32" ( _
                         ByRef lpSystemTime As SYSTEMTIME) As Long
                         
Private Declare Function SystemTimeToFileTime Lib "kernel32" ( _
                         ByRef lpSystemTime As SYSTEMTIME, _
                         ByRef lpFileTime As FILETIME) As Long
                         
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" ( _
                         ByRef lpFileTime As FILETIME, _
                         ByRef lpLocalFileTime As FILETIME) As Long
                         
Private Declare Function FileTimeToSystemTime Lib "kernel32" ( _
                         ByRef lpFileTime As FILETIME, _
                         ByRef lpSystemTime As SYSTEMTIME) As Long
                         
' ----==== WININET Deklarationen ====----
Private Declare Function HttpOpenRequest Lib "wininet" _
                         Alias "HttpOpenRequestA" ( _
                         ByVal hHttpSession As Long, _
                         ByVal sVerb As String, _
                         ByVal sObjectName As String, _
                         ByVal sVersion As String, _
                         ByVal sReferer As String, _
                         ByVal something As Long, _
                         ByVal lFlags As Long, _
                         ByVal lContext As Long) As Long
                         
Private Declare Function HttpQueryInfo Lib "wininet" _
                         Alias "HttpQueryInfoA" ( _
                         ByVal hHttpRequest As Long, _
                         ByVal lInfoLevel As Long, _
                         ByRef sBuffer As Any, _
                         ByRef lBufferLength As Long, _
                         ByRef lIndex As Long) As Integer

Private Declare Function HttpSendRequest Lib "wininet" _
                         Alias "HttpSendRequestA" ( _
                         ByVal hHttpRequest As Long, _
                         ByVal sHeaders As String, _
                         ByVal lHeadersLength As Long, _
                         ByRef sOptional As Any, _
                         ByVal lOptionalLength As Long) As Integer
                         
Private Declare Function InternetCloseHandle Lib "wininet" ( _
                         ByVal hInet As Long) As Integer
                         
Private Declare Function InternetConnect Lib "wininet" _
                         Alias "InternetConnectA" ( _
                         ByVal hInternetSession As Long, _
                         ByVal sServerName As String, _
                         ByVal nServerPort As Integer, _
                         ByVal sUsername As String, _
                         ByVal sPassword As String, _
                         ByVal lService As Long, _
                         ByVal lFlags As Long, _
                         ByVal lContext As Long) As Long
                         
Private Declare Function InternetOpen Lib "wininet" _
                         Alias "InternetOpenA" ( _
                         ByVal sAgent As String, _
                         ByVal lAccessType As Long, _
                         ByVal sProxyName As String, _
                         ByVal sProxyBypass As String, _
                         ByVal lFlags As Long) As Long
                         
Private Declare Function InternetTimeFromSystemTime Lib "wininet" ( _
                         ByRef pst As SYSTEMTIME, _
                         ByVal dwRFC As Long, _
                         ByVal lpszTime As String, _
                         ByVal cbTime As Long) As Long
                         
Private Declare Function InternetTimeToSystemTime Lib "wininet" ( _
                         ByVal lpszTime As String, _
                         ByRef pst As SYSTEMTIME, _
                         ByVal dwReserved As Long) As Long
                         
'------------------------------------------------------
' Funktion     : GetINetTime
' Beschreibung : Liest die aktuelle Internetzeit aus dem RequestHeader
' Übergabewert : Host = x-beliebige Internetadresse
' Rückgabewert : GMT-Zeit im RFC1123 Format (String)
'------------------------------------------------------
Public Function GetINetTime(ByVal Host As String) As String
    
    Dim strRet As String
    Dim strBuffer As String * 1024
    Dim lngBuffer As Long
    Dim sngStart As Single
    Dim hInternetSession As Long
    Dim hInternetConnect As Long
    Dim hHttpOpenRequest As Long
    
    ' größe des Buffers speichern
    lngBuffer = Len(strBuffer)
    
    ' Internetsession öffnen
    hInternetSession = InternetOpen(vbNullString, _
        INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0&)
        
    ' ist ein Handle vorhanden
    If hInternetSession <> 0& Then
    
        ' HTTP Session für den angegebenen Host offnen
        hInternetConnect = InternetConnect(hInternetSession, Host, _
            INTERNET_DEFAULT_HTTP_PORT, vbNullString, vbNullString, _
            INTERNET_SERVICE_HTTP, 0&, 0&)
            
        ' ist ein Handle vorhanden
        If hInternetConnect <> 0& Then
        
            ' HTTP Request öffnen
            hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "HEAD", _
                Host, "HTTP/1.1", vbNullString, 0&, INTERNET_FLAG_RELOAD, _
                0&)
                
            ' ist ein Handle vorhanden
            If hHttpOpenRequest <> 0& Then
            
                ' Startzeit für die Anfragedauer speichern
                sngStart = Timer
                
                ' Sendet einen Request an den HTTP Server
                If HttpSendRequest(hHttpOpenRequest, vbNullString, 0&, 0&, _
                    0&) <> 0& Then
                    
                    ' Informationen aus den Request Header auslesen
                    If HttpQueryInfo(hHttpOpenRequest, HTTP_QUERY_DATE, _
                        ByVal strBuffer, lngBuffer, 0&) <> 0& Then
                        
                        ' strRet enthält nun die Zeitangabe im RFC1123 Format
                        ' zB. Mon, 14 Jul 2008 11:05:49 GMT
                        strRet = Left$(strBuffer, lngBuffer)
                        
                        ' RFC1123 Format in das Date Format konvertieren
                        strRet = INetTimeToSystemTime(strRet)
                        
                        ' Anfragedauer addieren
                        strRet = CStr(DateAdd("s", CLng((Timer - sngStart) / _
                            2), CDate(strRet)))
                            
                        ' wieder in das RFC1123 Format konvertieren und ausgeben
                        GetINetTime = INetTimeFromSystemTime(CDate(strRet))
                        
                    End If
                End If
                
                ' Handle schließen
                Call InternetCloseHandle(hHttpOpenRequest)
                
            End If
            
            ' Handle schließen
            Call InternetCloseHandle(hInternetConnect)
            
        End If
        
        ' Handle schließen
        Call InternetCloseHandle(hInternetSession)
        
    End If
    
End Function

'------------------------------------------------------
' Funktion     : INetTimeToLocalTime
' Beschreibung : Konvertiert eine Zeitangabe im RFC1123 Format
'                in das Date Format (Lokal) um
' Übergabewert : InetTime = Zeitangabe im RFC1123 Format
' Rückgabewert : Lokale Zeit (String)
'------------------------------------------------------
Public Function INetTimeToLocalTime(ByVal InetTime As String) As String

    Dim tSysTime As SYSTEMTIME
    Dim tFileTime As FILETIME
    
    ' Zeitangabe im RFC1123 Format -> SYSTEMTIME
    If InternetTimeToSystemTime(InetTime, tSysTime, 0&) <> 0 Then
    
        ' SYSTEMTIME -> FILETIME
        If SystemTimeToFileTime(tSysTime, tFileTime) <> 0 Then
        
            ' FILETIME -> FILETIME (Lokal)
            If FileTimeToLocalFileTime(tFileTime, tFileTime) <> 0 Then
            
                ' FILETIME (Lokal) -> SYSTEMTIME
                If FileTimeToSystemTime(tFileTime, tSysTime) <> 0 Then
                
                    ' SYSTEMTIME -> DATE
                    INetTimeToLocalTime = CStr(DateSerial(tSysTime.wYear, _
                        tSysTime.wMonth, tSysTime.wDay) + TimeSerial( _
                        tSysTime.wHour, tSysTime.wMinute, tSysTime.wSecond))
                        
                End If
            End If
        End If
    End If
    
End Function

'------------------------------------------------------
' Funktion     : INetTimeFromSystemTime
' Beschreibung : Date Format in das RFC1123 Format konvertieren
' Übergabewert : SysTime = Date
' Rückgabewert : Zeitangabe im RFC1123 Format
'------------------------------------------------------
Public Function INetTimeFromSystemTime(ByVal SysTime As Date) As String

    Dim tSysTime As SYSTEMTIME
    Dim strRet As String * INTERNET_RFC1123_BUFSIZE
    
    ' Date -> SYSTEMTIME
    With tSysTime
    
        .wDay = Day(SysTime)
        .wMonth = Month(SysTime)
        .wYear = Year(SysTime)
        .wHour = Hour(SysTime)
        .wMinute = Minute(SysTime)
        .wSecond = Second(SysTime)
        
    End With
    
    ' Zeitangabe in das RFC1123 Format konvertieren
    If InternetTimeFromSystemTime(tSysTime, INTERNET_RFC1123_FORMAT, strRet, _
        INTERNET_RFC1123_BUFSIZE) <> 0 Then
        
        INetTimeFromSystemTime = Trim$(strRet)
        
    End If
    
End Function

'------------------------------------------------------
' Funktion     : INetTimeToSystemTime
' Beschreibung : Konvertiert eine Zeitangabe im RFC1123 Format
'                in das Date Format um
' Übergabewert : InetTime = Zeitangabe im RFC1123 Format
' Rückgabewert : Date (String)
'------------------------------------------------------
Public Function INetTimeToSystemTime(ByVal InetTime As String) As String

    Dim tSysTime As SYSTEMTIME
    
    ' Zeitangabe in das Date Format konvertieren
    If InternetTimeToSystemTime(InetTime, tSysTime, 0&) <> 0 Then
    
        INetTimeToSystemTime = CStr(DateSerial(tSysTime.wYear, _
            tSysTime.wMonth, tSysTime.wDay) + TimeSerial(tSysTime.wHour, _
            tSysTime.wMinute, tSysTime.wSecond))
            
    End If
    
End Function

'------------------------------------------------------
' Funktion     : SyncSystemTime
' Beschreibung : Setzt die Zeit der PC-Uhr
' Übergabewert : SyncTime = Date (GMT Zeit)
' Rückgabewert : True = setzen der Zeit war erfolgreich
'                False = setzen der Zeit war nicht erfolgreich
'------------------------------------------------------
Public Function SyncSystemTime(ByVal SyncTime As Date) As Boolean

    Dim tSysTime As SYSTEMTIME
    
    ' Date -> SYSTEMTIME
    With tSysTime
    
        .wDay = Day(SyncTime)
        .wMonth = Month(SyncTime)
        .wYear = Year(SyncTime)
        .wHour = Hour(SyncTime)
        .wMinute = Minute(SyncTime)
        .wSecond = Second(SyncTime)
        
    End With
    
    ' Systemzeit setzen
    SyncSystemTime = CBool(SetSystemTime(tSysTime))
    
End Function
'---------- Ende Modul "modMain" alias modMain.bas ----------
'-------------- Ende Projektdatei InetTime.vbp --------------