Server Clock

[kmchong]

Do anybody knows any way to sychronise the clock (date) of the server (NT and Unix) with the local PC?

Thanks a lot for any hint!

[LAURENS]

Put this code in a new module. It retrieves the server date/time for you. You can then use it tot set the datetime of your workstation.



Option Explicit
'
'
Private Declare Function NetRemoteTOD Lib "Netapi32.dll" (tServer As Any, pBuffer As Long) As Long
'
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
'
Private Type TIME_ZONE_INFORMATION
Bias As Long
StandardName(32) As Integer
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(32) As Integer
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
'
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
'
Private Declare Function NetApiBufferFree Lib "Netapi32.dll" (ByVal lpBuffer As Long) As Long
'
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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'
Public Function GetServerDateTime(ByVal strServer As String, dtRetDatum As Date) As Boolean
'
Dim dtResult As Date
Dim lngRetCode As Long
Dim TOD As TIME_OF_DAY_INFO
Dim lngBuff As Long
Dim tServer() As Byte
'
On Error GoTo ERROR_HANDLER

tServer = strServer & vbNullChar
lngRetCode = NetRemoteTOD(tServer(0), lngBuff)
'
If lngRetCode = 0 Then

CopyMemory TOD, ByVal lngBuff, Len(TOD)
NetApiBufferFree lngBuff
dtResult = DateSerial(TOD.tod_year, TOD.tod_month, TOD.tod_day) + _
TimeSerial(TOD.tod_hours, TOD.tod_mins - TOD.tod_timezone, TOD.tod_secs)
dtRetDatum = dtResult

Else

Err.Raise Number:=vbObjectError + 1001, _
Description:="cannot get remote TOD"

End If

GetServerDateTime = True

Exit Function

ERROR_HANDLER:
'
GetServerDateTime = False
'
End Function

[LAURENS]

Can anyone tell me how I can keep the indention in code I post ? This looks terrible.

[kmchong]

LAURENS,

the code that you posted, will it work for NT or UNIX? I know nothing about the Unix, so I cannot tell from your code what kind of server it is targetted for?

Thanks a lot anyway, at least I think it will work for at least one of the server. I will appreciate a LOTTTT... and have my tear running out if it can work for both kind of server.

[kmchong]

One more LAURENS,

when I use the function:
GetServerDateTime(ByVal strServer As String, dtRetDatum As Date)

does that means the return is stored in dtRetDatum if it is successful?

what is strServer, is it a ip address or exactly server name?

Thanks for your attention

[LAURENS]

Obviously this is code for NT. VB doesn't run on NT. This code uses win32 api-calls.


Datetime is stored in dtRetDatum (Datum is Dutch for Date)
strServer is an exact servername.

I bet you want to know now how you retrieve a server name. I've found a piece of code which among a lot of other information retrieves a servername.

I'll give you three classes. Just throw away the code I posted to you previously. You won't need the servername anymore, it will be retrieved automatically..

Class clsRemoteUsersInfo.

Option Explicit
'local variable(s) to hold property value(s)
Private mvarUsername As String
Private mvarLogonDomain As String
Private mvarOtherDomains As String
Private mvarLogonServer As String

Public Property Get LogonServer() As String
LogonServer = mvarLogonServer
End Property

Public Property Let LogonServer(ByVal vData As String)
mvarLogonServer = vData
End Property

Public Property Get OtherDomains() As String
OtherDomains = mvarOtherDomains
End Property

Public Property Let OtherDomains(ByVal vData As String)
mvarOtherDomains = vData
End Property

Public Property Get LogonDomain() As String
LogonDomain = mvarLogonDomain
End Property

Public Property Let LogonDomain(ByVal vData As String)
mvarLogonDomain = vData
End Property

Public Property Get Username() As String
Username = mvarUsername
End Property

Public Property Let Username(ByVal vData As String)
mvarUsername = vData
End Property
'*********************************************************
'End of this class
'**********************************************************

Put this code in another class, name it clsGetRemoteLoggedInUsers:

Option Explicit

'This class returns the logged in users on a remote or local
'Workstation when the HostName property is set by your Program
'It requires that the Class clsRemoteUsersInfo be added to project as well

'Api Structures
Private Type WKSTA_USER_INFO_1
lngUserName As Long
lngLogonDomain As Long
lngOtherDomains As Long
lngLogonServer As Long
End Type

'Error Constants
Const ERROR_BAD_NETPATH = 53&
Const ERROR_INVALID_NAME = 123&
Const ERROR_NOT_ENOUGH_MEMORY = 8
Const ERROR_INVALID_LEVEL = 124&
Const ERROR_INVALID_PARAMETER = 87
Const ERROR_MORE_DATA = 234
Const NERR_Success As Long = 0&


'Api Declares
Private Declare Function NetWkstaUserEnum Lib "Netapi32.dll" _
(ByVal strServerName As String, ByVal dwLevel As Long, _
lpBuffer As Long, ByVal dwPrefMaxLen As Long, _
lpdEntriesRead As Long, lpdTotalEntries As Long, _
lpdResumehandle As Long) As Long

Private Declare Function NetApiBufferFree Lib "netapi32" _
(ByVal pBuffer As Long) As Long

Private Declare Function NetApiBufferSize Lib "netapi32" _
(lpBuffer As Any, lpLength As Long) As Long

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
(pTo As Any, uFrom As Any, ByVal lSize As Long)

Private Declare Function lstrlenW Lib "kernel32" _
(ByVal lpString As Long) As Long

'local variable(s) to hold property value(s)
Private mvarNumberOfAccounts As Integer 'local copy
Private mvarServerName As String 'local copy
Private colUserAccounts As New Collection
Dim mvarUserAccounts As Collection 'local copy

Public Property Get UserAccounts() As Variant
If mvarUserAccounts Is Nothing Then
Set mvarUserAccounts = New Collection
End If
Set UserAccounts = mvarUserAccounts
End Property

Public Property Let ServerName(ByVal vData As String)
mvarServerName = vData
GotServerName (mvarServerName)
End Property

Public Property Get ServerName() As String
ServerName = mvarServerName
End Property

Public Property Get NumberOfAccounts() As Integer
NumberOfAccounts = mvarNumberOfAccounts
End Property

Private Function PtrToString(lpwString As Long) As String
'Convert a LPWSTR pointer to a VB string
Dim Buffer() As Byte
Dim nLen As Long

If lpwString Then
nLen = lstrlenW(lpwString) * 2
If nLen Then
ReDim Buffer(0 To (nLen - 1)) As Byte
CopyMem Buffer(0), ByVal lpwString, nLen
PtrToString = Buffer
End If
End If
End Function

Private Sub GotServerName(ByVal strHostName As String)
Dim lngLevel As Long
Dim lngPrefmaxlen As Long
Dim lngEntriesRead As Long
Dim lngTotalEntries As Long
Dim lngResumeHandle As Long
Dim lngReturn As Long
Dim lngLength As Long
Dim lngBuffer As Long
Dim typWkStaInfo(0 To 1000) As WKSTA_USER_INFO_1
Dim intCount As Integer
Dim CurrentInfo As clsRemoteUsersInfo

'Check for the right syntax for the servername
'Convert it to unicode because the C function wants a LPCWSTR
'ie LongPointer to a unicode string, the C stands for a constants
'vbNullString for the local Machine
If strHostName = "" Then
strHostName = vbNullString
Else
If InStr(strHostName, "\\") <> 0 Then
strHostName = StrConv(strHostName & vbNullChar, vbUnicode)
Else
strHostName = StrConv("\\" & strHostName & vbNullChar, vbUnicode)
End If
End If
'set the resumehandle to the first entry
lngResumeHandle = 0
'Define the new Collection
Set mvarUserAccounts = New Collection
'Call the function, the -1 passed to dwPrefMaxLen lets the function create its
'own buffer that will hold all the data returned, I choose to enumerate at level 1
'you can pass a level 0, feel free to modify
lngReturn = NetWkstaUserEnum(strHostName, &H1, lngBuffer, -1, lngEntriesRead, lngTotalEntries, lngResumeHandle)
'if successful ie NERR_Success get the info
If lngReturn = NERR_Success Then
'initialize the count variable
intCount = 0
'Get the size of the memory allocated
lngReturn = NetApiBufferSize(ByVal lngBuffer, lngLength)
'Copy the memory into the array so we can get the information out
'I imagine this could cause really strange things to happen if you happen to
'have more then 1000 users logged into this workstation. I tried to dump the info into
'a dynamic array and VB keep generating a Doctor Watson error everytime the
'sub exited beats me why, If anybody know email me
CopyMem typWkStaInfo(0), ByVal lngBuffer, lngLength
'Get the info out and add it too are collection
For intCount = 0 To lngTotalEntries - 1
'temporay object to hold the info
Set CurrentInfo = New clsRemoteUsersInfo
'The info returned is actually a LP, which we have to convert
'I used Andrea Tincani's function which transforms the returned LPWSTR to a string
CurrentInfo.Username = PtrToString(typWkStaInfo(intCount).lngUserName)
CurrentInfo.LogonDomain = PtrToString(typWkStaInfo(intCount).lngLogonDomain)
CurrentInfo.LogonServer = PtrToString(typWkStaInfo(intCount).lngLogonServer)
CurrentInfo.OtherDomains = PtrToString(typWkStaInfo(intCount).lngOtherDomains)
'add it to the collection
mvarUserAccounts.Add CurrentInfo, CurrentInfo.Username
'destroy our temporary object
Set CurrentInfo = Nothing
'One more done
intCount = intCount + 1
Next
Else
'our function failed lets find out why
GoTo GetErrMsg
End If
'We have to free up the Memory the funtion allocated for our data
If lngBuffer Then
Call NetApiBufferFree(ByVal lngBuffer)
End If

Exit Sub
GetErrMsg:
ReturnErrorMsg (lngReturn)
End Sub

Private Function ReturnErrorMsg(ByVal errorcode As Long)
Select Case errorcode
Case 53
MsgBox "Error: Bad netpath"
Case 123
MsgBox "Error: Invalid Host Name"
Case 8
MsgBox "Error: Not enough Memory"
Case 124
MsgBox "Error: Invalid Level, you don't have the authority to run this"
Case 87
MsgBox "Error: Invalid Parameter"
Case 234
MsgBox "Error: error more data"
End Select
End Function
'*********************************************************
'End of this class
'**********************************************************



USE THIS CODE INSTEAD OF THE CODE I PREVIOUSLY POSTED.
PUT THIS IN A CLASS TOO. Name it clsGetServerDate
Option Explicit
'
'
Private Declare Function NetRemoteTOD Lib "Netapi32.dll" (tServer As Any, pBuffer As Long) As Long
'
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
'
Private Type TIME_ZONE_INFORMATION
Bias As Long
StandardName(32) As Integer
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(32) As Integer
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
'
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
'
Private Declare Function NetApiBufferFree Lib "Netapi32.dll" (ByVal lpBuffer As Long) As Long
'
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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'
Public Function GetServerDateTime(dtRetDatum As Date) As Boolean
'
Dim strServerName As String

Dim dtResult As Date
Dim lngRetCode As Long
Dim lngBuff As Long
Dim tServer() As Byte
Dim TOD As TIME_OF_DAY_INFO
Dim x As clsGetRemoteLoggedInUsers
'
On Error GoTo ERROR_HANDLER

Set x = New clsGetRemoteLoggedInUsers
x.ServerName = ""
' I can't retrieve the logonservername without useraccounts.
If x.UserAccounts.Count > 0 Then
strServerName = x.UserAccounts(1).LogonServer

tServer = strServerName & vbNullChar
lngRetCode = NetRemoteTOD(tServer(0), lngBuff)
'
If lngRetCode = 0 Then

CopyMemory TOD, ByVal lngBuff, Len(TOD)
NetApiBufferFree lngBuff
dtResult = DateSerial(TOD.tod_year, TOD.tod_month, TOD.tod_day) + _
TimeSerial(TOD.tod_hours, TOD.tod_mins - TOD.tod_timezone, TOD.tod_secs)
dtRetDatum = dtResult

Else

Err.Raise Number:=vbObjectError + 1001, _
Description:="cannot get remote TOD"

End If

GetServerDateTime = True
Else
GetServerDateTime = False
End If

Set x = Nothing

Exit Function

ERROR_HANDLER:
'
GetServerDateTime = False
'
End Function

'End of this class
*****************************************************
*****************************************************
Example of usage:
Private sub SomeSub
dim dtServerDateTime as Date
dim clsServerdata as clsGetServerDate

Set clsServerDate = New clsGetServerDate

If Not clsServerDate.GetServerDateTime(dtServerDateTime) Then
dtServerDateTime = Now 'If function fails take clienttime instead.
End If

set clsserverdate = nothing

end sub

[hozo]

Oh My GOD! All that code to set the clock!? What are you guys smoking and where can I get some! LOL

Try this man..

Shell "NET.EXE TIME \\NTSERVERNAME /SET /YES", vbMinimizedNoFocus


Some notes...
1) if the workstation is on any kind of network, net.exe will be installed.
2) You might want to use the winsys api to get the Windows Path and put that infront of the net.exe incase (for some odd reason) the windows path is not in the system path/search comspec.
3) Net.exe is different between 95/98, NT and 2000 however the command still might work.. but even if that all you need is a few lines of code to determine the os, and then use a select to use the right net.exe parameters.. but STILL a lot less code then all that above.
4) Shell also is a function that can return whether the program was executed or not
5) NT servers have time server ability built in.