Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1092to1096
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Datum Online abfragen 2

Datum Online abfragen 2
Max
Hallo zusammen.
Mein Problem ist, daß ich für eine Zeitschloßfunktion das Datum Online abrufen muß, weil die Systemzeit zu einfach manipulierbar ist.
Vor nem Jahr wurde mir hier dafür mit einer Lösung geholfen
https://www.herber.de/forum/archiv/988to992/t989105.htm
die bis vor kurzem einwandfrei funktionierte.

Sub datum_online()
Dim Start As Date
Dim IEApp As Object
Dim IEDocument As Object
Set IEApp = CreateObject("InternetExplorer.Application")
IEApp.Visible = False
IEApp.Navigate "http://www.nuruhr.de/"
Start = Now
Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False
Do
If DateDiff("s", Start, Now) > 10 Then Exit Do
Loop Until IEApp.ReadyState  4
Set IEDocument = IEApp.Document
MsgBox IEDocument.all.Date.innertext
Set IEDocument = Nothing
Set IEApp = Nothing
End Sub
Meine VBA Kenntnisse sind zwar besser geworden aber ich hab keinen Schimmer wie ich es wieder zum laufen kriegen kann.
Die adresse im IE leitet inzwischen auf http://www.atom-uhrzeit.de/
weiter und mit IEDocument.all.awieruiyuiv345.innertext krieg ich auch problemlos die Zeit, bloß mit dem originalen IEDocument.all.Date.innertext fürs Datum krieg ich den Fehler 438 "Objekt unterstützt die eigenschaft nicht".
Ich hab probiert es anzupaasen und Alternativen zu finden, komm aber schlichtweg seit Stunden einfach nicht weiter.
Kennt jemand eine Lösung um das alte Makro anzupassen oder kennt eine Alternative um das Datum online abzurufen?

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Datum Online abfragen 2
08.08.2009 18:12:12
Josef
Hallo Max,
wie ist's damit.
' **********************************************************************
' Modul: Modul4 Typ: Allgemeines Modul
' **********************************************************************

'src:= http://www.vbfun.de/cgi-bin/loadframe.pl?ID=vb/tipps/tip0460.shtml

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 < 11005 Then
    strErrMsg = "Probleme beim Erstellen des Sockets!"
    GoTo err_Handler
  End If
  
  adresse.sin_family = AF_INET
  adresse.sin_addr = inet_addr(SERVER_IP)
  adresse.sin_port = htons(37)
  connect_ans = connect(socket_ans, adresse, Len(adresse))
  If connect_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

Gruß Sepp

Anzeige
@Sepp...
08.08.2009 18:25:30
robert
hi Sepp,
sag einmal, wie entsteht denn sowas ?
unglaublich !!! :-)
gruß
robert
AW: @Sepp...
08.08.2009 18:31:13
Josef
Hallo Robert,
naja, der Code ist ja nicht von mir, ausserdem sieht es komplizierter aus als es ist, sind im Prinzip nur ein paar API-Aufrufe.
Gruß Sepp

Danke-nicht kompliziert-naja....owT
08.08.2009 18:33:18
robert
AW: Datum Online abfragen 2
08.08.2009 19:17:15
Max
Herlzlichsten Dank. Passt und funktioniert perfekt!

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige