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)) Dieser Tipp wurde bereits 14.938 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevOutBar 4.0 Vertikale Menüleisten á la Outlook Erstellen von Outlook ähnlichen Benutzer- interfaces - mit beliebig vielen Gruppen und Symboleinträgen. Moderner OfficeXP-Style mit Farbverläufen, Balloon-Tips, u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
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. |