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.961 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. |
sevAniGif (VB/VBA) Anzeigen von animierten GIF-Dateien Ab sofort lassen sich auch unter VB6 und VBA (Access ab Version 2000) animierte GIF-Grafiken anzeigen und abspielen, die entweder lokal auf dem System oder auf einem Webserver gespeichert sind. Tipp des Monats Mai 2024 Hermann Röttger Wochentage eines Datumsbereichs ermitteln Wochentage eines Datumsbereichs ermitteln, optional mit Feiertagsberechnung TOP Entwickler-Paket TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... |
||||||||||||||||
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. |