AW: Datum/Uhrzeit im Internet abfragen VBA
17.06.2017 12:09:09
Nepumuk
Hallo Steffen,
teste mal:
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 GetTimeZoneInformation Lib "kernel32.dll" ( _
ByRef lpTZI As TIME_ZONE_INFORMATION) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare Function WSAGetLastError Lib "ws2_32.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
Private Function InternetTime() As Date
Const SERVER_IP As String = "192.53.103.104"
Dim udtData As WSADATA, udtAdresse As SOCKADDR
Dim udtTimeZone As TIME_ZONE_INFORMATION
Dim strTime As String, strRecv_Data As String * 5
Dim dblTimeStamp As Double
Dim lngStartup_Return As Long, lngSocket_Return As Long
Dim lngConnect_Return As Long, lngReceive_Return As Long
Dim lngClose_Return As Long, lngTZI_Return As Long
Dim lngGTC_Return_1 As Long
lngStartup_Return = WSAStartup(WS_VERSION_REQD, udtData)
If lngStartup_Return <> 0 Then Exit Function
lngSocket_Return = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
If lngSocket_Return > 10000 And lngSocket_Return < 11005 Then Exit Function
udtAdresse.sin_family = AF_INET
udtAdresse.sin_addr = inet_addr(SERVER_IP)
udtAdresse.sin_port = htons(37)
lngConnect_Return = connect(lngSocket_Return, udtAdresse, Len(udtAdresse))
If lngConnect_Return <> 0 Then Exit Function
lngGTC_Return_1 = GetTickCount()
lngReceive_Return = recv(lngSocket_Return, strRecv_Data, Len(strRecv_Data), 0)
strTime = Left$(strRecv_Data, lngReceive_Return)
If lngReceive_Return <> 4 Then Exit Function
lngClose_Return = closesocket(lngSocket_Return)
If lngClose_Return <> 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#
lngTZI_Return = GetTimeZoneInformation(udtTimeZone)
If lngTZI_Return = TIME_ZONE_ID_DAYLIGHT Then
dblTimeStamp = dblTimeStamp - (udtTimeZone.Bias * 60 + _
udtTimeZone.DaylightBias * 60)
Else
dblTimeStamp = dblTimeStamp - udtTimeZone.Bias * 60
End If
lngGTC_Return_1 = Round((GetTickCount - lngGTC_Return_1) / 1000, 0)
dblTimeStamp = dblTimeStamp + lngGTC_Return_1
InternetTime = DateAdd("s", dblTimeStamp, "1.1.2000")
End Function
Public Sub GetDateTime()
Dim dtmNow As Date
dtmNow = InternetTime
MsgBox TimeValue(dtmNow)
MsgBox DateValue(dtmNow)
End Sub
Gruß
Nepumuk