Update ngày giờ của hệ thống qua Internet

siwtom · 20/4/14

Tôi sửa lại code bài #28 như sau. Bạn nào test thì xin cho biết kết quả. Chỉ xét Windows >= XP

code

Mã:

Sub SetDateTimeFormNet(ByVal zone_offset As Long, ByVal zone_name As String)
Dim GMT_Time As String, currDateTime As String, currDate As Date, currTime As Date
Dim http As Object, shell As Object, sCmd As String, sMonth, s As String, index As Long
 
Const GMTTime As String = "http://wwp.greenwichmeantime.com/time/scripts/clock-8/runner.php?tz=gmt"
sMonth = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

On Error Resume Next

    s = Application.OperatingSystem
    index = InStr(1, s, "NT")
    If index > 0 Then index = Mid(s, index + 3, 1)
    If index > 5 Then
        sCmd = "cmd.exe /c TZUTIL /s " & zone_name
    ElseIf index = 5 Then
        sCmd = "cmd.exe /c rundll32.exe shell32.dll,Control_RunDLL timedate.cpl,,/Z " & zone_name
    Else
        Exit Sub
    End If
    
    Set shell = CreateObject("WScript.Shell")
    shell.Run sCmd, 0, True
    
    Set http = CreateObject("Microsoft.XMLHTTP")
     
    http.Open "GET", GMTTime & Now(), False, "", ""
    http.send
     
    GMT_Time = http.getResponseHeader("Date")
    
    GMT_Time = Mid$(GMT_Time, 6, Len(GMT_Time) - 9)
    For index = 0 To 11
        s = Mid(GMT_Time, 3, 5)
        If InStr(1, s, sMonth(index)) > 0 Then
            GMT_Time = Replace(GMT_Time, s, Application.International(xlDateSeparator) & _
                                        Format(index + 1, "00") & Application.International(xlDateSeparator))
            Exit For
        End If
    Next
     
    currDateTime = DateAdd("h", zone_offset, GMT_Time)
    currDate = DateValue(currDateTime)
    currTime = Format(TimeValue(currDateTime), "hh:mm:ss")
    
    shell.Run "%comspec% /c time " & currTime, False
    shell.Run "%comspec% /c date " & currDate, False
    
    Set shell = Nothing
    Set http = Nothing
End Sub

Gọi cho Việt Nam

Mã:

SetDateTimeFormNet 7, "SE Asia Standard Time"

Hoàng Trọng Nghĩa · 20/4/14

siwtom đã viết:
Gọi cho Việt Nam

Mã:

SetDateTimeFormNet 7, "SE Asia Standard Time"

Không biết có phải laptop của em "miễn nhiễm" với code can thiệp thời gian hay sao mà code nào cũng không tác dụng can thiệp vào ngày giờ hệ thống, chỉ chỉnh được bằng tay thôi.

siwtom · 20/4/14

Hoàng Trọng Nghĩa đã viết:
Không biết có phải laptop của em "miễn nhiễm" với code can thiệp thời gian hay sao mà code nào cũng không tác dụng can thiệp vào ngày giờ hệ thống, chỉ chỉnh được bằng tay thôi.

Code cũ có 2 vấn đề: thiết lập ngày giờ sai nếu trong CP chọn <> Anh, và nếu khi chuyển hđh thì phải sửa code. Vì sao?

Vì

Mã:

sCmd = "cmd.exe /c TZUTIL /s " & zone_name

chỉ chạy trên Win 7 còn

Mã:

sCmd = "cmd.exe /c rundll32.exe shell32.dll,Control_RunDLL timedate.cpl,,/Z " & zone_name

chỉ chạy trên XP. Như thế thì rất rách việc. Nhiều khi tập tin có code ta chuyển cho đồng nghiệp, đối tác thì chả nhẽ lại giải thích cho họ: anh sửa "chỗ này chỗ này"?

Tôi sửa chỉ với 2 mục đích trên. Bạn chuyển hđh qua lại nhưng không phải sửa vì sau khi hỏi tôi mới biết là bạn không quan tâm tới múi giờ.

Còn về vấn đề của bạn thì bạn thì gõ trực tiếp trong dòng lệnh

Mã:

time 07:35:22 --> ENTER

và xem giờ có đổi không và có thông báo gì trong dòng lệnh không. Tương tự cho date.

Hoàng Trọng Nghĩa · 20/4/14

siwtom đã viết:
Còn về vấn đề của bạn thì bạn thì gõ trực tiếp trong dòng lệnh

Mã:

time 07:35:22 --> ENTER

và xem giờ có đổi không và có thông báo gì trong dòng lệnh không. Tương tự cho date.

Em đã từng gõ vào Immediate:

date = #20/3/2014#

Nhưng nó báo lỗi:

Runtime Error '70':

Permission dinied

siwtom · 20/4/14

Hoàng Trọng Nghĩa đã viết:
Em đã từng gõ vào Immediate:

date = #20/3/2014#

Nhưng nó báo lỗi:

Runtime Error '70':

Permission dinied

Nếu là "Permission denied" thì rõ rồi. Nói chuyện mà cứ giấu thông tin thì mất thời gian lắm

Tôi không nghiên cứu Win 7 nhưng bạn có thể thử 1 trong 2 cách

1. Tắt UAC rồi chạy code
2. Chạy EXCEL với quyền của Administrator --> mở tập tin có code --> chạy code

Bởi nếu bạn thao tác trực tiếp trong dòng lệnh (tôi nghĩ bạn thao tác thử trực tiếp trong dòng lệnh cũng chả mất bao nhiêu thời gian) mà cũng không được thì ắt là do bị cấm.

Hoàng Trọng Nghĩa · 20/4/14

siwtom đã viết:
Nếu là "Permission denied" thì rõ rồi. Nói chuyện mà cứ giấu thông tin thì mất thời gian lắm

Tôi không nghiên cứu Win 7 nhưng bạn có thể thử 1 trong 2 cách

1. Tắt UAC rồi chạy code
2. Chạy EXCEL với quyền của Administrator --> mở tập tin có code --> chạy code

Bởi nếu bạn thao tác trực tiếp trong dòng lệnh (tôi nghĩ bạn thao tác thử trực tiếp trong dòng lệnh cũng chả mất bao nhiêu thời gian) mà cũng không được thì ắt là do bị cấm.

Em còn không biết nguyên do nữa Thầy ơi, làm sao mà giấu được, lúc Thầy hỏi mới chạy và thấy lỗi đó.

Em tắt UAC rồi chạy code thì đã OK rồi Thầy ơi.

trieubb · 15/8/18

ndu96081631 đã viết:

Đúng rồi, ngày tháng hơi khó 1 chút vì phải xem Control Panel đang định dạng là d/M/y hay M/d/y
Giờ viết lại, Set cả ngày và giờ luôn nhé:

Mã:

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Integer, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Integer, ByVal lpfnCB As Integer) As Integer
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Integer

Mã:

Sub DownloadFile(ByVal sURL As String, ByVal FileName As String)
  DeleteUrlCacheEntry sURL
  URLDownloadToFile 0, sURL, FileName, 0, 0
End Sub

Mã:

Function InternetDateTime() As Double
  Dim sTmp As String, sURL As String, FileName As String
  Dim fso As Object, aTmp, Arr(1 To 2)
  sURL = "http://www.timeanddate.com/worldclock/city.html?n=95"
  Set fso = CreateObject("Scripting.FileSystemObject")
  FileName = fso.GetTempName
  DownloadFile sURL, FileName
  With fso.OpenTextFile(FileName, 1)
    sTmp = .ReadAll
    .Close
  End With
  Set fso = Nothing: Kill (FileName)
  sTmp = Mid(sTmp, InStr(1, sTmp, "Current Time"))
  sTmp = Mid(sTmp, 1, InStr(1, sTmp, "</strong>") - 1)
  sTmp = Mid(sTmp, InStr(1, sTmp, "big>") + 4)
  aTmp = Split(sTmp, " at ")
  Arr(2) = TimeValue(aTmp(1))
  sTmp = Trim(Replace(aTmp(0), ",", ""))
  aTmp = Split(sTmp, " ")
  Arr(1) = DateValue(aTmp(2) & "-" & aTmp(1) & "-" & aTmp(3))
  InternetDateTime = CLng(Arr(1)) + CDbl(Arr(2))
End Function

Mã:

Sub Main()
  Dim sComm As String, sTime As String, sDate As String, sFormat As String
  Dim dNow As Double
  dNow = InternetDateTime
  sTime = Format(dNow, "hh:mm:ss")
  Select Case Application.International(xlDateOrder)
    Case Is = 0: sFormat = "MM/dd/yyyy"
    Case Is = 1: sFormat = "dd/MM/yyyy"
    Case Is = 2: sFormat = "yyyy/MM/dd"
  End Select
  sDate = Format(dNow, sFormat)
  sComm = "cmd.exe /c Time " & sTime
  CreateObject("WScript.Shell").Run sComm, 0, True
  sComm = "cmd.exe /c Date " & sDate
  CreateObject("WScript.Shell").Run sComm, 0, True
End Sub

bản WIN 64bit báo lỗi chỗ "Private Declare Function ..." anh ơi

trieubb · 17/8/18

lại lỗi dòng này
sTmp = Mid(sTmp, InStr(1, sTmp, "Current Time"))

Update ngày giờ của hệ thống qua Internet

siwtom

Thành viên gắn bó

Hoàng Trọng Nghĩa

Chuyên gia GPE

siwtom

Thành viên gắn bó

Hoàng Trọng Nghĩa

Chuyên gia GPE

siwtom

Thành viên gắn bó

Hoàng Trọng Nghĩa

Chuyên gia GPE

trieubb

Thành viên mới

trieubb

Thành viên mới

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian