Option Explicit
'Fetch and display Net Remote Time Of Day from a
'remote Windows system. Supply a UNC hostname
'(or a DNS name), or empty string for the local
'host's time and date.
'
'Form has 3 controls:
'
' txtServer TextBox
' cmdGetTime CommandButton
' lblTime Label
Private Const NERR_SUCCESS As Long = 0
Private Type TIME_OF_DAY_INFO
tod_elapsedt As Long
tod_msecs As Long
tod_hours As Long
tod_mins As Long
tod_secs As Long
tod_hunds As Long
tod_timezone As Long
tod_tinterval As Long
tod_day As Long
tod_month As Long
tod_year As Long
tod_weekday As Long
End Type
Private Declare Function NetApiBufferFree Lib "netapi32" _
(ByVal lpBuffer As Long) As Long
Private Declare Function NetRemoteTOD Lib "netapi32" _
(UncServerName As Byte, _
BufferPtr As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pTo As Any, _
uFrom As Any, _
ByVal lSize As Long)
Private Function GetTOD(ByVal Server As String) As Date
Dim bytServer() As Byte
Dim lngBufPtr As Long
Dim todReturned As TIME_OF_DAY_INFO
bytServer = Server & vbNullChar
If NetRemoteTOD(bytServer(0), lngBufPtr) = NERR_SUCCESS Then
CopyMemory todReturned, ByVal lngBufPtr, LenB(todReturned)
NetApiBufferFree lngBufPtr
With todReturned
If .tod_timezone = -1 Then .tod_timezone = 0
GetTOD = DateAdd("n", _
-.tod_timezone, _
DateSerial(.tod_year, .tod_month, .tod_day) _
+ TimeSerial(.tod_hours, .tod_mins, .tod_secs))
End With
Else
Err.Raise vbObjectError + 2000, _
"GetTOD", _
"Failed to obtain server time"
End If
End Function
Private Sub cmdGetTime_Click()
Dim dtServerTime As Date
txtServer.Text = Trim$(txtServer.Text)
If Len(txtServer.Text) > 0 Then
On Error Resume Next
dtServerTime = GetTOD(txtServer.Text)
If Err.Number <> 0 Then
lblTime.Caption = Err.Description
Else
lblTime.Caption = CStr(dtServerTime)
End If
On Error GoTo 0
Else
Beep
End If
txtServer.SetFocus
End Sub