[RESOLVED] based time of timer from server

[enigmagirl122]

Hello

I want to add a timer on my task monitor just a start/stop button.Is it possible the time of the timer control of my program is based from the server without affecting the system time of the computer where the program is installed.

thanks!

[dee-u]

Yes you can, have a look at the following codes:

Option Explicit

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 Declare Function SetSystemTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME) As Long
Private Declare Function SendNotifyMessage _
   Lib "user32" Alias "SendNotifyMessageA" _
   (ByVal hwnd As Long, _
    ByVal MSG As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    
Private Const NERR_SUCCESS             As Long = 0&
Private Const WM_TIMECHANGE            As Long = &H1E&
Private Const HWND_BROADCAST           As Long = &HFFFF

Private Type TIME_OF_DAY_INFO
   tod_elapsed                         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 NetGetDCName Lib "netapi32.dll" ( _
                ServerName As Byte, _
                DomainName As Byte, _
                ppBuffer As Long) As Long
Private Declare Function NetRemoteTOD Lib "netapi32.dll" ( _
                yServer As Any, _
                pBuffer As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32.dll" ( _
                ByVal pBuffer As Long) As Long
Private Declare Sub CopyMem Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
                pTo As Any, _
                uFrom As Any, _
                ByVal lSize As Long)
Private Declare Function StrLenW Lib "kernel32" Alias "lstrlenW" ( _
                ByVal Ptr As Long) As Long
 
'CSEH: ErrSkipReplacement
Public Function GetServerTime(Optional ByVal xi_strServerName As String = "-PDC-") As Date
    On Error GoTo HandleError
    Dim p_typTimeOfDay      As TIME_OF_DAY_INFO
    Dim p_lngPtrBuffer      As Long
    Dim p_lngRtn            As Long
    Dim p_strServerName     As String
    Dim p_abytServerName()  As Byte
    
    If xi_strServerName = "-PDC-" Then
        p_strServerName = Get_DCName("")
    Else
        p_strServerName = xi_strServerName
    End If
    
    If Trim$(p_strServerName) = vbNullString Then
        p_abytServerName = Chr$(0)
    Else
        If Left$(p_strServerName, 2) <> "\\" Then
            p_strServerName = "\\" & p_strServerName
        End If
        p_abytServerName = p_strServerName & Chr$(0)
    End If
    
    p_lngRtn = NetRemoteTOD(yServer:=p_abytServerName(0), _
       pBuffer:=p_lngPtrBuffer)
    
    If p_lngRtn = NERR_SUCCESS Then
       
        CopyMem pTo:=p_typTimeOfDay, _
           uFrom:=ByVal p_lngPtrBuffer, _
           lSize:=Len(p_typTimeOfDay)
               
        ' The buffer will contain the UTC (Universal
        ' Coordinated Time) of the server, and must
        ' be adjusted by TOD_TIMEZONE minutes
        ' for the correct local time.
        GetServerTime = DateSerial(p_typTimeOfDay.tod_year, _
           p_typTimeOfDay.tod_month, _
           p_typTimeOfDay.tod_day) + _
           TimeSerial(p_typTimeOfDay.tod_hours, _
           (p_typTimeOfDay.tod_mins - p_typTimeOfDay.tod_timezone), _
           p_typTimeOfDay.tod_secs)
    Else
        GetServerTime = Now
    End If
    
    If p_lngPtrBuffer <> 0 Then
        NetApiBufferFree p_lngPtrBuffer
    End If
    PopStack
    Exit Function
HandleError:
    LogMessage "Error in modGetServerTime.GetServerTime"
    GetServerTime = Now
End Function
 
'CSEH: ErrSkipReplacement
Private Function Get_DCName(ByVal xi_strDomainName As String) As String
    On Error GoTo HandleError
    Dim p_lngRtn            As Long
    Dim p_abytDomainName()  As Byte
    Dim p_lngPtrBuffer      As Long
    Dim p_strDomainName     As String
   
    p_abytDomainName = Trim$(xi_strDomainName) & vbNullChar
    p_lngRtn = NetGetDCName(ServerName:=0&, _
       DomainName:=p_abytDomainName(0), _
       ppBuffer:=p_lngPtrBuffer)
   
    ' ------------------------------------------
    ' If the function succeeds, the return value
    '     is NERR_Success.
    ' ------------------------------------------
    If p_lngRtn <> NERR_SUCCESS Then
        ' This is an error
        p_strDomainName = ""
        Get_DCName = ""
    Else
        p_strDomainName = p_abytDomainName
        Get_DCName = PointerToUnicodeStr(p_lngPtrBuffer)
    End If

    ' ------------------------------------------
    ' Clean up the buffer before exit
    ' ------------------------------------------
    If p_lngPtrBuffer <> 0 Then
        Call NetApiBufferFree(p_lngPtrBuffer)
    End If
    PopStack
    Exit Function
HandleError:
    LogMessage "Error in Get_DCName"
End Function

'CSEH: ErrSkipReplacement
Private Function PointerToUnicodeStr(ByVal xi_lngPtrToString As Long) As String
    On Error Resume Next                   ' Don't accept an error here
    Dim p_abytBuffer()                  As Byte
    Dim p_lngLen                        As Long
    Dim p_strTmp                        As String
       
    ' ------------------------------------------
    ' Get the length of the string from the pointer
    ' ------------------------------------------
    p_lngLen = StrLenW(xi_lngPtrToString) * 2
   
    ' ------------------------------------------
    ' Now convert to a string
    ' ------------------------------------------
    If xi_lngPtrToString <> 0 Then
        If p_lngLen > 0 Then
            ReDim p_abytBuffer(0 To (p_lngLen - 1)) As Byte
            CopyMem p_abytBuffer(0), ByVal xi_lngPtrToString, p_lngLen
            p_strTmp = p_abytBuffer
        Else
            p_strTmp = ""
        End If
    End If
   
    ' ------------------------------------------
    ' Set the return value
    ' ------------------------------------------
    PointerToUnicodeStr = p_strTmp
   
End Function

Public Function SetLocalTime(Optional ByVal xi_strServerName As String = "-PDC-") As Boolean
    Dim p_lngPtrBuffer                  As Long
    Dim p_lngRtn                        As Long
    Dim p_strServerName                 As String
    Dim p_typSysTime                    As SYSTEMTIME
    Dim p_typTimeOfDay                  As TIME_OF_DAY_INFO
    Dim p_abytServerName()              As Byte

    If xi_strServerName = "-PDC-" Then
        p_strServerName = Get_DCName("")
    Else
        p_strServerName = xi_strServerName
    End If
   
    If Trim$(p_strServerName) = vbNullString Then
        p_abytServerName = Chr$(0)
    Else
        If Left$(p_strServerName, 2) <> "\\" Then
            p_strServerName = "\\" & p_strServerName
        End If
        p_abytServerName = p_strServerName & Chr$(0)
    End If
   
    p_lngRtn = NetRemoteTOD(yServer:=p_abytServerName(0), _
       pBuffer:=p_lngPtrBuffer)
   
    If p_lngRtn = NERR_SUCCESS Then
      
        CopyMem pTo:=p_typTimeOfDay, _
           uFrom:=ByVal p_lngPtrBuffer, _
           lSize:=Len(p_typTimeOfDay)
              
        p_typSysTime.wDay = p_typTimeOfDay.tod_day
        p_typSysTime.wMonth = p_typTimeOfDay.tod_month
        p_typSysTime.wYear = p_typTimeOfDay.tod_year
        p_typSysTime.wHour = p_typTimeOfDay.tod_hours
        p_typSysTime.wMinute = p_typTimeOfDay.tod_mins
        p_typSysTime.wSecond = p_typTimeOfDay.tod_secs
                  
        p_lngRtn = SetSystemTime(p_typSysTime)
      
        If p_lngRtn <> 0 Then
            SetLocalTime = True
         
            p_lngRtn = SendNotifyMessage(hwnd:=HWND_BROADCAST, _
               MSG:=WM_TIMECHANGE, _
               wParam:=0&, _
               lParam:=0&)
        Else
            SetLocalTime = False
        End If
      
    Else
        ' Raise an error
        SetLocalTime = False
        MsgBox "Error Setting time from Server.   ", vbCritical, "Error Encountered"
    End If
   
    If p_lngPtrBuffer <> 0 Then
        NetApiBufferFree p_lngPtrBuffer
    End If

End Function

Sample Usage:

Private Sub Command1_Click()
    Dim x As Date
    x = GetServerTime("\\Server1")
    MsgBox x
End Sub

[enigmagirl122]

thanks dee for the reply.i get error message "Sub or function not defined" and i noticed that the code for popstack function is missing.


Thanks!

[dee-u]

I forgot to remove them, you can just remove them, those are my own functions for my stack tracing.

[enigmagirl122]

ok, salamat...