'Responde Bhuo a una pregunta
'de como sincronizar las fechas entre ordenadores.
'La cuestion era que alguien tiene una aplicacion de
'Access, separada formularios y datos.
'Y desea controlar que los usuarios no les cambien
'la fecha en cada PC y si lo hacen, que de inmediato
'el programa recoja la fecha real del Servidor


Option Compare Database
Option Explicit
Public Declare Function NetRemoteTOD Lib "NETAPI32.DLL" _
                                (yServer As Any, _
                                 pBuffer As Long) As Long

Public Declare Function NetApiBufferFree Lib "NETAPI32.DLL" _
                                (ByVal lpBuffer As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                                (hpvDest As Any, _
                                 hpvSource As Any, _
                                 ByVal cbCopy As Long)

Private Type TIME_OF_DAY
  Elapsedt As Long
  Msecs As Long
  Hours As Long
  Mins As Long
  Secs As Long
  Hunds As Long
  Timezone As Long
  Tinterval As Long
  Day As Long
  Month As Long
  Year As Long
  Weekday As Long
End Type

Const NERR_SUCESS = 0

Public Function fndServerTime() As Date

Dim udtTime As TIME_OF_DAY
Dim pudtTime As Long
Dim lResult As Long
Dim abServer() As Byte
Dim dServDate As Date
Dim PserveRName As String
Dim TPTR
PserveRName = "PC_SERVER"
    'Este nombre le buscas en el entorno de RED para saber
    'como se llama, bajo la red de Windows, el servidor de datos
    abServer = "\\" & PserveRName
    lResult = NetRemoteTOD(abServer(0), pudtTime)
    
    If lResult = NERR_SUCESS Then
        'Ahora hay que copiar esa zona de memoria a nuestro udt.
        CopyMemory udtTime, ByVal pudtTime, Len(udtTime)
        NetApiBufferFree (TPTR)
        
        'Por ultimo montamos la fecha
        With udtTime
        dServDate = DateSerial(.Year, .Month, .Day)
        dServDate = dServDate + TimeSerial(.Hours, .Mins - .Timezone, .Secs)
        fndServerTime = dServDate
        Date = dServDate
        
       End With
    Else
        'Error. Poner tratamiento de errores (Ej: no existe el servidor)
    End If

End Function