WEBINAR: On-demand webcast
How to Boost Database Development Productivity on Linux, Docker, and Kubernetes with Microsoft SQL Server 2017 REGISTER >
Author: Lothar Haensler
This small piece of code returns a VB Date and will raise an error if the
NetRemoteTOD- API call fails. It takes care of all time-zone information - place the following code into a standard BAS module :
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 getRemoteTOD(byval strServer as string) as date ' Dim result as date Dim lRet as Long Dim tod as TIME_OF_DAY_INFO Dim lpbuff as Long Dim tServer() as Byte ' tServer = strServer & vbNullChar lRet = NetRemoteTOD(tServer(0), lpbuff) ' If lRet = 0 then CopyMemory tod, byval lpbuff, len(tod) NetApiBufferFree lpbuff result = DateSerial(tod.tod_year, tod.tod_month, _ tod.tod_day) + _ TimeSerial(tod.tod_hours, tod.tod_mins - tod.tod_timezone, _ tod.tod_secs) getRemoteTOD = result else Err.Raise Number:=vbObjectError + 1001, _ Description:="cannot get remote TOD" End If ' End Function
private Sub Command1_Click() Dim d as date ' d = GetRemoteTOD("your NT server name goes here") MsgBox d End Sub ' ' '
Download BAS module