Datum Online abrufen

Option Explicit
Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal _
wVersionRequired As Integer, ByRef lpWSAData As WSADATA) _
As Long
Private Declare Function socket Lib "ws2_32.dll" (ByVal af As _
Long, ByVal lType As Long, ByVal protocol As Long) As Long
Private Declare Function connect Lib "ws2_32.dll" (ByVal s As _
Long, ByRef Name As SOCKADDR, ByVal namelen As Long) As Long
Private Declare Function htons Lib "ws2_32.dll" (ByVal hostshort _
As Integer) As Integer
Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As _
String) As Long
Private Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, _
ByVal buf As String, ByVal lLen As Long, ByVal flags _
As Long) As Long
Private Declare Function closesocket Lib "ws2_32.dll" (ByVal s _
As Long) As Long
Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare Function WSAGetLastError Lib "ws2_32.dll" () _
As Long
Private Declare Function GetTimeZoneInformation Lib _
"kernel32.dll" (lpTZI As TIME_ZONE_INFORMATION) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Const WS_VERSION_REQD As Long = &H101&
Private Const WSADESCRIPTION_LEN As Long = 256
Private Const WSASYS_STATUS_LEN As Long = 128
Private Const AF_INET As Long = 2
Private Const SOCK_STREAM As Long = 1
Private Const IPPROTO_TCP As Long = 6
Private Const TIME_ZONE_ID_DAYLIGHT As Long = 2
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSADESCRIPTION_LEN
szSystemStatus As String * WSASYS_STATUS_LEN
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Type SOCKADDR
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero As String * 8
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
Private Type TIME_ZONE_INFORMATION
Bias As Long
StandardName(31) As Integer
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(31) As Integer
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
Dim startup_ans As Long
Dim socket_ans As Long
Dim connect_ans As Long
Dim recv_ans As Long
Dim recv_data As String * 5
Dim close_ans As Long
Dim TZI_ans As Long
Dim GTC_ans_1 As Long
'IP des Servers
Private Const SERVER_IP As String = "131.188.3.221" 'ntp1.rrze.uni-erlangen.de
Private Const AUTO_UPDATE As Boolean = True
Private Const SHOW_ANS As Boolean = True
Private Sub Main()
Dim data As WSADATA
Dim adresse As SOCKADDR
Dim Zeit_Roh As String
Dim Zeitstempel As Double
Dim Zeit As Date
Dim Zeitzone As TIME_ZONE_INFORMATION
Dim strErrMsg As String
strErrMsg = ""
startup_ans = WSAStartup(WS_VERSION_REQD, data)
If startup_ans  0 Then
strErrMsg = "Probleme beim Initiieren der Sockets!"
GoTo err_Handler
End If
socket_ans = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
If socket_ans > 10000 And socket_ans  0 Then
strErrMsg = "Kann nicht zum Server " & SERVER_IP & _
" verbinden!"
GoTo err_Handler
End If
GTC_ans_1 = GetTickCount()
recv_ans = recv(socket_ans, recv_data, Len(recv_data), 0)
Zeit_Roh = Left$(recv_data, recv_ans)
If recv_ans  4 Then
strErrMsg = "Unverständliche Daten!"
GoTo err_Handler
End If
close_ans = closesocket(socket_ans)
If close_ans  0 Then
strErrMsg = "Fehler beim Schließen des Sockets!"
GoTo err_Handler
End If
WSACleanup
Zeitstempel = Asc(Mid(Zeit_Roh, 1, 1)) * 256 ^ 3 + _
Asc(Mid(Zeit_Roh, 2, 1)) * 256 ^ 2 + _
Asc(Mid(Zeit_Roh, 3, 1)) * 256 ^ 1 + _
Asc(Mid(Zeit_Roh, 4, 1)) - 3155673600#
TZI_ans = GetTimeZoneInformation(Zeitzone)
If TZI_ans = TIME_ZONE_ID_DAYLIGHT Then
Zeitstempel = Zeitstempel - (Zeitzone.Bias * 60 + _
Zeitzone.DaylightBias * 60)
Else
Zeitstempel = Zeitstempel - Zeitzone.Bias * 60
End If
GTC_ans_1 = Round((GetTickCount - GTC_ans_1) / 1000, 0)
Zeitstempel = Zeitstempel + GTC_ans_1
Zeit = DateAdd("s", Zeitstempel, "1.1.2000")
' If AUTO_UPDATE = True Then
' Date = DateValue(Zeit)
' Time = TimeValue(Zeit)
' End If
If SHOW_ANS = True Then
MsgBox "Die aktuelle Zeit: " & CStr(Zeit) & vbCrLf & _
"Korrekturfaktor: " & CStr(GTC_ans_1), _
vbInformation, "Die Aktuelle Zeit..."
End If
Exit Sub
err_Handler:
MsgBox strErrMsg, vbCritical, "FEHLER!"
End Sub