Soru İnternet tarihini baz almak

[Cengizhantr06]

Sub demo()

Dim saat1 As Date

Dim saat2 As Date

saat1 = "15/10/2005"

saat2 = Date

If saat2 > saat1 Then

MsgBox ("Süreniz dolmuş üzgünüm.")

ActiveWorkbook.Close

End If

MsgBox ("Kullanım için " & saat1 - saat2 & " gününüz kalmıştır.") If sure1 = sure2 Then

MsgBox "Bu gün SON GÜN"

End If

End Sub

Merhaba bu kod bilgisayar tarihi değilde Internet bağlantısı sorgulayıp internet tarihini baz alacak şekilde revize edebilirmiyiz acaba ?

 

[muhasebeciyiz]

Sub demo()
    Dim saat1 As Date
    Dim internetTarihi As Date
    Dim xmlhttp As Object
    Dim url As String
    Dim jsonResponse As String
    Dim startPos As Long
    Dim endPos As Long
    Dim datetimeString As String
    
    saat1 = "15/10/2005"
    
    url = "http://worldtimeapi.org/api/timezone/Europe/Istanbul"
    
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
    xmlhttp.Open "GET", url, False
    xmlhttp.Send
    
    jsonResponse = xmlhttp.responseText
    
    startPos = InStr(jsonResponse, """datetime"":""") + Len("""datetime"":""")
    endPos = InStr(startPos, jsonResponse, """")
    datetimeString = Mid(jsonResponse, startPos, endPos - startPos)
    
    datetimeString = Replace(datetimeString, "T", " ")
    datetimeString = Replace(datetimeString, "Z", "")
    
    On Error GoTo ErrorHandler
    
    If Len(datetimeString) >= 19 Then
        internetTarihi = CDate(Mid(datetimeString, 1, 19))
    Else
        MsgBox "Geçerli bir tarih alınamadı: " & datetimeString
        Exit Sub
    End If
  
    internetTarihi = DateAdd("h", -0, internetTarihi)
    
    MsgBox "saat1: " & saat1 & vbCrLf & "internetTarihi: " & internetTarihi
    
    If internetTarihi < saat1 Then
        MsgBox ("Kullanım için " & DateDiff("d", internetTarihi, saat1) & " gününüz kalmıştır.")
    ElseIf internetTarihi = saat1 Then
        MsgBox "Bu gün SON GÜN"
    End If
    
    Exit Sub
    
ErrorHandler:
    MsgBox "Tarih dönüştürme hatası: " & Err.Description

End Sub

Deneyiniz

 

[Cengizhantr06]

çok teşekkür ederim @muhasebeciyiz pc başına geçince deneyecem