AW: Atomzeit
10.11.2016 08:04:36
Nepumuk
Hallo,
ein Beispiel:
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" ( _
ByRef 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
Public Function InternetTime() As Date
'Eine Liste der Deutschen Zeitserver findes du hier:
'http://www.hullen.de/helmut/filebox/DCF77/ntpsrvr.html
Const SERVER_IP As String = "192.53.103.108" 'ptb in Braunschweig
Dim udtData As WSADATA, udtAdresse As SOCKADDR
Dim udtTimeZone As TIME_ZONE_INFORMATION
Dim strTime As String, strRecvData As String * 5
Dim dblTimeStamp As Double
Dim dtmTime As Date
Dim lngStartupReturn As Long, lngSocketReturn As Long
Dim lngConnectReturn As Long, lngReceiveReturn As Long
Dim lngCloseReturn As Long, lngTZIReturn As Long
Dim lngGTCReturn As Long
lngStartupReturn = WSAStartup(WS_VERSION_REQD, udtData)
If lngStartupReturn <> 0 Then Exit Function
lngSocketReturn = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
If lngSocketReturn > 10000 And lngSocketReturn < 11005 Then Exit Function
udtAdresse.sin_family = AF_INET
udtAdresse.sin_addr = inet_addr(SERVER_IP)
udtAdresse.sin_port = htons(37)
lngConnectReturn = connect(lngSocketReturn, udtAdresse, Len(udtAdresse))
If lngConnectReturn <> 0 Then Exit Function
lngGTCReturn = GetTickCount()
lngReceiveReturn = recv(lngSocketReturn, strRecvData, Len(strRecvData), 0)
strTime = Left$(strRecvData, lngReceiveReturn)
If lngReceiveReturn <> 4 Then Exit Function
lngCloseReturn = closesocket(lngSocketReturn)
If lngCloseReturn <> 0 Then Exit Function
Call WSACleanup
dblTimeStamp = Asc(Mid(strTime, 1, 1)) * 256 ^ 3 + _
Asc(Mid(strTime, 2, 1)) * 256 ^ 2 + _
Asc(Mid(strTime, 3, 1)) * 256 ^ 1 + _
Asc(Mid(strTime, 4, 1)) - 3155673600#
lngTZIReturn = GetTimeZoneInformation(udtTimeZone)
If lngTZIReturn = TIME_ZONE_ID_DAYLIGHT Then
dblTimeStamp = dblTimeStamp - (udtTimeZone.Bias * 60 + _
udtTimeZone.DaylightBias * 60)
Else
dblTimeStamp = dblTimeStamp - udtTimeZone.Bias * 60
End If
lngGTCReturn = Round((GetTickCount - lngGTCReturn) / 1000, 0)
dblTimeStamp = dblTimeStamp + lngGTCReturn
dtmTime = DateAdd("s", dblTimeStamp, DateSerial(2000, 1, 1))
InternetTime = dtmTime
End Function
Public Sub GetDateTime()
Dim dtmNow As Date
dtmNow = InternetTime
If dtmNow <> 0 Then
Call MsgBox(DateValue(dtmNow), vbInformation, "Information")
Else
Call MsgBox("Fehler beim Lesen der Internetzeit.", vbCritical, "Programmabbruch")
End If
End Sub
Gruß
Nepumuk