Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
Przesunięty przez: Artik
15-12-2016, 20:36
Aktualizacja systemowej daty i systemowego czasu.
Autor Wiadomość
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2126 razy
Posty: 7041
Wysłany: 15-12-2016, 19:47   Aktualizacja systemowej daty i systemowego czasu.

Ostatnio dość często musiałem zmieniać czas i datę systemową, i w związku z tym napisałem małą funkcyjkę aktualizującą datę i czas.
Może kiedyś komuś się przyda - zawsze to mniej klikania niż miał by to robić w Windows-ie ;-)

Kod:
Sub test()
    MsgBox GetNow(1, 1)  'Time = GetNow(1, 1)
    MsgBox GetNow(2, 1)  'Date = GetNow(2, 1)
    MsgBox GetNow(3, 1)  'Data and Time
End Sub

Function GetNow(DateTime As Byte, TimeZone As Integer) As Date
'*******************************************************************
'* DateTime:                                                       *
'* 1 - Time                                                        *
'* 2 - Date                                                        *
'* 3 - Data and Time                                               *
'* TimeZone - integer number (Difference to Greenwich Mean Time)   *
'* TimeZone map - https://www.timeanddate.com/time/map/            *
'*******************************************************************
    Dim XHTTP As Object
    Dim Arr As Variant

    On Error GoTo GetNow_Error

    Set XHTTP = CreateObject("MSXML2.XMLHTTP")
    With XHTTP
        .Open "Head", "http://time.windows.com/", False
        .Send
        Arr = Split(.GetResponseHeader("Date"), " ")
    End With

    Select Case Arr(2)
    Case "Jan": Arr(2) = 1
    Case "Feb": Arr(2) = 2
    Case "Mar": Arr(2) = 3
    Case "Apr": Arr(2) = 4
    Case "May": Arr(2) = 5
    Case "Jun": Arr(2) = 6
    Case "Jul": Arr(2) = 7
    Case "Aug": Arr(2) = 8
    Case "Sep": Arr(2) = 9
    Case "Oct": Arr(2) = 10
    Case "Nov": Arr(2) = 11
    Case "Dec": Arr(2) = 12
    End Select

    Select Case DateTime
    Case 1: GetNow = TimeValue(Arr(4)) + 1 / 24 * TimeZone
    Case 2: GetNow = Format(DateSerial(Arr(3), Arr(2), Arr(1)) + TimeValue(Arr(4)) + 1 / 24 * TimeZone, "yyyy-mm-dd")
    Case 3: GetNow = DateSerial(Arr(3), Arr(2), Arr(1)) + TimeValue(Arr(4)) + 1 / 24 * TimeZone
    End Select

    Set XHTTP = Nothing

    On Error GoTo 0
    Exit Function

GetNow_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in function GetNow "

End Function
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
Ostatnio zmieniony przez Marecki 04-05-2017, 21:54, w całości zmieniany 1 raz  
ID posta: 310624 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2126 razy
Posty: 7041
Wysłany: 04-05-2017, 21:30   

Chyba popełniłem małą gafę , bo instrukcja
Kod:
.GetResponseHeader("Date")
podaje czas serwerowy GMT - Greenwich Mean Time i o ten czas oparte są chyba wszystkie serwery ( tam mi się przynajmniej wydaje - jeśli się mylę to proszę mnie poprawić )
a ja w kodzie na sztywno przypisałem
Kod:
+ 1 / 24 * TimeZone
, a należało by argument funkcji TimeZone wyliczyć, uwzględniając czas letni i czas zimowy.
Oczywiście sytuacji takiej unikniemy jak już nie będziemy mieszać czasem +/- 1h.

Druga sprawa, wynikająca z powyższego to adres www.
Skoro czas brany jest nagłówka jakiejś strony i wiadomo że to będzie czas GMT to najlepiej wybrać stronę szybko wczytującą się - czyli pustą.
Zatem zamieńmy w kodzie:
Kod:
.Open "Head", "http://time.windows.com/", False
na
Kod:
.Open "Head", "https://www.google.com/blank.html", False


Dla zainteresowanych poniżej zamieszczam ciut inną funkcję opartą o stronę https://time.is/
Strona ta istnieje w sieci od 2001/07/25 ,czyli raczej wiarygodna i miejmy nadzieję że nie zniknie przez kolejne 16 lat.
Na stronie znajdują się ciekawa funkcja podająca różnicę czasową między naszym czasem systemowym a czasem UTC(Universal Time Coordinated) -przycisk Time.is, oprócz tego po prawej stronie jest okienko wyszukiwania , do którego możemy wpisać dowolną miejscowość świata.
Kod:
Public Function Get_Time() As Date
    Dim oHtml As Object
    Set oHtml = CreateObject("htmlfile")
   
    Application.Volatile
   
    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", "https://time.is/Poland", False
        .Send
        oHtml.Body.innerHTML = .responseText
    End With
   
    Get_Time = oHtml.getElementById("twd").innerText
End Function
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 322014 Skopiuj do schowka
 
 
Zbiniek 
Excel Expert



Zaproszone osoby: 2
Wersja: Win Office 2013
Pomógł: 408 razy
Posty: 2615
Wysłany: 05-05-2017, 11:44   

Na bazie Twojego powyższego kodu pozwoliłem sobie skrobnąć funkcję do pobieraniu i daty, i czasu. Nie mam jak sprawdzić czy wynik na innych wersjach językowych systemu będzie zgodny z oczekiwanym.
Kod:
Public Function Get_DateAndTime() As Date
   Dim oHtml As Object
   Dim sData$
   Dim sCzas$
   Dim sDataArr As Variant
   Set oHtml = CreateObject("htmlfile")
   
   Application.Volatile
   
   With CreateObject("WINHTTP.WinHTTPRequest.5.1")
      .Open "GET", "https://time.is", False
      .Send
      oHtml.Body.innerHTML = .responseText
   End With
   
   sData = oHtml.getElementById("dd").innerText
   sDataArr = Split(sData, " ")
   sData = sDataArr(1) & " " & sDataArr(2) & " " & Int(sDataArr(3))
   sCzas = oHtml.getElementById("twd").innerText
   Get_DateAndTime = CDate(sData) & " " & sCzas

   Set oHtml = Nothing

End Function
_________________
pozdrawiam
Zbiniek

Pisz po polsku! Jest różnica czy siedzisz w sadzie czy w sądzie. "Język polski jest ą-ę" :-)

Prawdopodobieństwo otrzymania satysfakcjonującej odpowiedzi jest proporcjonalne do właściwego sformułowania problemu (popartego załącznikiem).

Jest załącznik - jest impreza

http://rtfm.killfile.pl/
ID posta: 322045 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2126 razy
Posty: 7041
Wysłany: 05-05-2017, 13:14   

zbiniek napisał/a:
pozwoliłem sobie skrobnąć
Super. :beer
zbiniek napisał/a:
Nie mam jak sprawdzić
Masz. Wystarczy w opcjach regionalnych sytsemu zmienić format daty i czasu np. na Angielski (Stany Zjednoczone)
zbiniek napisał/a:
będzie zgodny z oczekiwanym.
Otóż nie będzie, bo funkcja CDate wywali błąd wykonania.
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 322059 Skopiuj do schowka
 
 
Zbiniek 
Excel Expert



Zaproszone osoby: 2
Wersja: Win Office 2013
Pomógł: 408 razy
Posty: 2615
Wysłany: 05-05-2017, 13:43   

Teraz powinno być lepiej :-)

Kod:
Public Function Get_DateAndTime() As Date
   Dim oHtml As Object
   Dim sData$
   Dim sCzas$
   Dim sDataArr As Variant
   Set oHtml = CreateObject("htmlfile")
   
   Application.Volatile
   
   With CreateObject("WINHTTP.WinHTTPRequest.5.1")
      .Open "GET", "https://time.is", False
      .Send
      oHtml.Body.innerHTML = .responseText
   End With
   
   sData = oHtml.getElementById("dd").innerText
   sDataArr = Split(sData, " ")
   Select Case sDataArr(2)
      Case "stycznia":     sDataArr(2) = 1
      Case "lutego":       sDataArr(2) = 2
      Case "marca":        sDataArr(2) = 3
      Case "kwietnia":     sDataArr(2) = 4
      Case "maja":         sDataArr(2) = 5
      Case "czerwca":      sDataArr(2) = 6
      Case "lipca":        sDataArr(2) = 7
      Case "sierpnia":     sDataArr(2) = 8
      Case "września":     sDataArr(2) = 9
      Case "października": sDataArr(2) = 10
      Case "listopada":    sDataArr(2) = 11
      Case "grudnia":      sDataArr(2) = 12
   End Select
   sData = sDataArr(1) & " " & sDataArr(2) & " " & Int(sDataArr(3))
   sCzas = oHtml.getElementById("twd").innerText
   Get_DateAndTime = CDate(sData) & " " & sCzas
   Set oHtml = Nothing
End Function
_________________
pozdrawiam
Zbiniek

Pisz po polsku! Jest różnica czy siedzisz w sadzie czy w sądzie. "Język polski jest ą-ę" :-)

Prawdopodobieństwo otrzymania satysfakcjonującej odpowiedzi jest proporcjonalne do właściwego sformułowania problemu (popartego załącznikiem).

Jest załącznik - jest impreza

http://rtfm.killfile.pl/
ID posta: 322063 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2647 razy
Posty: 8778
Wysłany: 06-05-2017, 08:49   

zbiniek, mam obawy o linię
Kod:
 sData = sDataArr(1) & " " & sDataArr(2) & " " & Int(sDataArr(3))
To może nie być jednoznaczne określenie daty (problem 02.05 - 2 maja, czy 5 lutego). Obawiam się, że przy specyficznych ustawieniach systemu, przy konwersji może dochodzić do niewłaściwej interpretacji. Z dotychczasowych obserwacji wynika, że jednoznaczną datę otrzymujemy używając:
1. DateSerial()
2. tekst daty w formacie "d mmmm yyyy", gdzie miesiąc jest wyrażony tekstem w języku lokalnym systemu
3. tekst daty w formacie "yyyy-mm-dd" (nigdzie na świecie nie używa się szyku "Y-D-M").

I zamiast Case-ów pętelka, co powinno zadziałać na wszystkich systemach (tak mi się przynajmniej wydaje)
Kod:
Function Get_DateAndTime() As Date
    Dim oHtml As Object
    Dim sData$
    Dim sCzas$
    Dim sDataArr As Variant
    Dim i As Long
    Dim vCstmLst As Variant
   
    Set oHtml = CreateObject("htmlfile")
     
    Application.Volatile
     
    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
       .Open "GET", "https://time.is", False
       .Send
       oHtml.Body.innerHTML = .responseText
    End With
     
    sData = oHtml.getElementById("dd").innerText
    sDataArr = Split(sData, " ")
   
      '3-literowe skróty nazw miesięcy w języku lokalnym
      vCstmLst = Application.GetCustomListContents(3)
     
      For i = 1 To UBound(vCstmLst)
        If LCase(sDataArr(2)) Like LCase(vCstmLst(i)) & "*" Then
          Exit For
        End If
      Next i
   
    sData = Int(sDataArr(3)) & "-" & i & "-" & sDataArr(1)
    sCzas = oHtml.getElementById("twd").innerText
   
    Get_DateAndTime = CDate(sData & " " & sCzas)
   
    Set oHtml = Nothing
 End Function


Zapraszam do przetestowania na odporność rozwiązania. Szczególnie "Amerykanów" i "Brytyjczyków" oraz innych "nacji".

Artik

ID posta: 322092 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2126 razy
Posty: 7041
Wysłany: 06-05-2017, 11:08   

Artik, oooo, a tego co napisałeś w mod info nie doczytałem, słuszna uwaga.
W związku z tym poprawiłem pierwszą funkcję z wątku.
Teraz uwzględnia ona zmianę czasu (zimowy - letni) w naszej strefie:
Kod:
Sub test()
    MsgBox GetNow(1)  'Time
    MsgBox GetNow(2)  'Date
    MsgBox GetNow(3)  'Data and Time
End Sub

Function GetNow(DateTime As Byte) As Date
'*******************************************************************
'* DateTime:                                                       *
'* 1 - Time                                                        *
'* 2 - Date                                                        *
'* 3 - Data and Time                                               *
'*******************************************************************
    Dim XHTTP As Object
    Dim Arr As Variant
    Dim MyDate As Date
    Dim SummerTime As Long
    Dim WinterTime As Long
    Dim TimeZone

    On Error GoTo GetNow_Error

    Set XHTTP = CreateObject("MSXML2.XMLHTTP")
    With XHTTP
        .Open "Head", "https://www.google.com/blank.html", False
        .Send
        Arr = Split(.GetResponseHeader("Date"), " ")
    End With


    Arr(2) = Switch(Arr(2) = "Jan", 1, Arr(2) = "Feb", 2, Arr(2) = "Mar", 3, Arr(2) = "Apr", 4, _
                    Arr(2) = "May", 5, Arr(2) = "Jun", 6, Arr(2) = "Jul", 7, Arr(2) = "Aug", 8, _
                    Arr(2) = "Sep", 9, Arr(2) = "Oct", 10, Arr(2) = "Nov", 11, Arr(2) = "Dec", 12)

    MyDate = DateSerial(Arr(3), Arr(2), Arr(1))
    SummerTime = DateSerial(Arr(3), 4, 1) - Weekday(DateSerial(Arr(3), 4, 1), 2)
    WinterTime = DateSerial(Arr(3), 11, 1) - Weekday(DateSerial(Arr(3), 11, 1), 2)

    TimeZone = Evaluate("=IF(MEDIAN(" & SummerTime & ":" & WinterTime & "," & MyDate & ")<>" & MyDate & ",1,2)")

    Select Case DateTime
    Case 1: GetNow = TimeValue(Arr(4)) + 1 / 24 * TimeZone
    Case 2: GetNow = Format(DateSerial(Arr(3), Arr(2), Arr(1)) + TimeValue(Arr(4)) + 1 / 24 * TimeZone, "yyyy-mm-dd")
    Case 3: GetNow = DateSerial(Arr(3), Arr(2), Arr(1)) + TimeValue(Arr(4)) + 1 / 24 * TimeZone
    End Select

    Set XHTTP = Nothing

    On Error GoTo 0
    Exit Function

GetNow_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in function GetNow "

End Function
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 322097 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2647 razy
Posty: 8778
Wysłany: 06-05-2017, 12:14   

mkkk23 napisał/a:
Kod:
Dim MyDate As Date
Dim SummerTime As Long
Dim WinterTime As Long
(...)
TimeZone = Evaluate("=IF(MEDIAN(" & SummerTime & ":" & WinterTime & "," & MyDate & ")<>" & MyDate & ",1,2)")
Przy moich chwilowo dziwacznych ustawieniach --> Error 2015.
Dlaczego dwukropek, a nie przecinek? :shock:
Po zmianie deklaracji na
Kod:
Dim MyDate As Long 'Date
przeszło bez problemów. Przy typie Date, mimo zamiany dwukropka na przecinek, błąd jw.

Jak się nie mylę, to Evaluate wymaga sprowadzenia daty do formatu amerykańskiego.

Artik
ID posta: 322103 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2126 razy
Posty: 7041
Wysłany: 06-05-2017, 12:30   

Cytat:
Dlaczego dwukropek, a nie przecinek?
bo formuła wygląda tak:
Kod:
=JEŻELI(MEDIANA(B2:C2;E2)<>E2;"zima";"lato")
załącznik.
Może być też przecinek, bo w formule w arkuszu można też zapisać to tak:
Kod:
=JEŻELI(MEDIANA(B2;C2;E2)<>E2;"zima";"lato")
czyli używając średnika.
Oczywiście zmieniłem "zima lato" na wartości liczbowe.

Artik napisał/a:
Po zmianie deklaracji na
Skoro tak to zmieńmy deklarację MyDate na Long.
Dlaczego u Ciebie się to wywaliło nie wiem, u mnie zadziałało bez zarzutu.

Evaluate wylicza czas przesunięcia od czasu GMT - czyli wylicza przesunięcie czasu letniego i zimowego.

Czas.xlsm
Pobierz Plik ściągnięto 125 raz(y) 20.61 KB

_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 322104 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe