Aktuelle Atomzeit ermitteln Dieser Tipp zeigt, wie man die aktuelle Atomzeit ermitteln kann.
Autor:   Microsys Kramer	Bewertung:	Views:  14.950
www.access-paradies.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Zur Ermittlung der Atomzeit wird diese von der Internet-Seite der Uni Köln geladen. Der Anbieter kann die Interseite jederzeit ändern oder anpassen. In diesem Fall muss der Code dieses Tipps ebenfalls angepasst werden.

Option Explicit
 
' Benötigte API-Deklarationen 
Private Declare Sub InternetCloseHandle Lib "wininet.dll" ( _
  ByVal hInet As Long)
 
Private Declare Function InternetOpenA Lib "wininet.dll" ( _
  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 InternetOpenUrlA Lib "wininet.dll" ( _
  ByVal hOpen As Long, _
  ByVal sUrl As String, _
  ByVal sHeaders As String, _
  ByVal lLength As Long, _
  ByVal lFlags As Long, _
  ByVal lContext As Long) As Long
 
Private Declare Sub InternetReadFile Lib "wininet.dll" ( _
  ByVal hFile As Long, _
  ByVal sBuffer As String, _
  ByVal lNumBytesToRead As Long, _
  lNumberOfBytesRead As Long)
 
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0&
Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1&
Private Const INTERNET_OPEN_TYPE_PROXY As Long = 3&

Public Function OpenURL(ByVal URL As String) As String
  ' // -----------------------------------------------------------
  ' // Methode:   | Öffnet eine übergebene Internet-Adresse
  ' // -----------------------------------------------------------
  ' // Parameter: | URL - gültige http-Adresse
  ' // -----------------------------------------------------------
  ' // Rückgabe:  | Inhalt der Internetseite
  ' // -----------------------------------------------------------
 
  Const INTERNET_FLAG_RELOAD = &H80000000
 
  Dim hInet   As Long
  Dim hURL    As Long
  Dim Buffer  As String * 2048
  Dim Bytes   As Long
 
  hInet = InternetOpenA("Internet", INTERNET_OPEN_TYPE_PRECONFIG, _
    vbNullString, vbNullString, 0)
  hURL = InternetOpenUrlA(hInet, URL, vbNullString, 0, _
    INTERNET_FLAG_RELOAD, 0)
 
  Do
    InternetReadFile hURL, Buffer, Len(Buffer), Bytes
    If Bytes = 0 Then Exit Do
    OpenURL = OpenURL & Left$(Buffer, Bytes)
  Loop
 
  InternetCloseHandle hURL
  InternetCloseHandle hInet
 
End Function

Function GetAtomicTime() As Variant
  ' // ------------------------------------------------------------
  ' // Methode:   | Ermittelt die Atomzeit der Internet-Adresse der
  ' //            | Universität Köln
  ' // ------------------------------------------------------------
  ' // Parameter: | keine
  ' // ------------------------------------------------------------
  ' // Rückgabe:  | Atomzeit als Variant (Date)
  ' // ------------------------------------------------------------
  On Error GoTo Err_GetAtomicTime
 
  Const URL = "http://www.uni-koeln.de/bin2/zeit/"
 
  Dim HTML      As String
  Dim tmp_Start    As Long
  Dim tmp_End      As Long
  Dim sData() As String
 
  HTML = OpenURL(URL)
 
  ' <span>Fri Sep 15 10:21:21 2006<br />
  tmp_Start = InStr(1, HTML, "<span>") + 6
  tmp_End = InStr(tmp_Start, HTML, "<") - 1
  HTML = Trim$(Mid$(HTML, tmp_Start, tmp_End - tmp_Start + 1))
 
  ' Daten splitten und wie folgt formatieren
  ' dd.mm.yyyy hh:nn:ss
  sData = Split(Replace(HTML, "  ", " "), " ")
  HTML = Format$(Val(sData(2)), "00") & "." & GetMonth(sData(1)) & "." & sData(4) & " " & sData(3)
  GetAtomicTime = CVDate(HTML)
 
Exit_GetAtomicTime:
  Exit Function
 
Err_GetAtomicTime:
  ' Bei Fehler wird die Systemzeit des PCs zurückgeben
  MsgBox "Atomzeit konnte nicht ermittelt werden." & vbCrLf & _
    "Fehler: " & CStr(Err.Number) & vbCrLf & Err.Description, vbCritical
 
  GetAtomicTime = Now
  Resume Exit_GetAtomicTime
End Function

' Hilfsfunktion
Private Function GetMonth(ByVal sMonth As String)
  Select Case sMonth
    Case "Jan"
      GetMonth = "01"
    Case "Feb"
      GetMonth = "02"
    Case "Mar"
      GetMonth = "03"
    Case "Apr"
      GetMonth = "04"
    Case "May"
      GetMonth = "05"
    Case "Jun"
      GetMonth = "06"
    Case "Jul"
      GetMonth = "07"
    Case "Aug"
      GetMonth = "08"
    Case "Sep"
      GetMonth = "09"
    Case "Oct"
      GetMonth = "10"
    Case "Nov"
      GetMonth = "11"
    Case "Dec"
      GetMonth = "12"
  End Select
End Function

Möchten Sie die Atomzeit als Systemzeit setzten, verwenden Sie folgenden Code:

Dim vDate As Variant
vDate = GetAtomicTime
Date = DateSerial(Year(vDate), Month(vDate), Day(vDate))
Time = TimeSerial(Hour(vDate), Minute(vDate), Second(vDate))

Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.

Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.