.: Links :.

Home | Forums | Desert Computer Agents

.: Retracting Windows NT Rights With Visual Basic 6 :.
By Nicholas A. Hall

 
	



Form1.frm
Private Declare Function RtlAdjustPrivilege Lib "ntdll" (ByVal Privilege As Long, ByVal bEnablePrivilege As Long, ByVal bCurrentThread As Long, ByRef OldState As Long) As Long

Private Sub Form_Load()
    Me.Hide
    Winsock1.Connect "time-a.timefreq.bldrdoc.gov", 37
    LSAPrivileges.RevokePriv
    
    'This Will Undo it and allow you to change the time once again
    'LSAPrivileges.ChangeAccessRights True, Environ$("USERDOMAIN") & "\" & Environ$("USERNAME")
End Sub

Private Sub Winsock1_Close()
   Debug.Print "   closing connection"
   Debug.Print "   sockets closed"
   Call SyncSystemClock(sNTP)
   End
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim sData As String
   Winsock1.GetData sData, vbString
   sNTP = sNTP & sData
   Debug.Print "data received: " & sData & "    (" & bytesTotal & " bytes)"
   Winsock1.Close
   Winsock1_Close
End Sub
ChangePermissions.bas
Option Explicit
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Const STILL_ACTIVE = &H103
Const PROCESS_QUERY_INFORMATION = &H400

' Global constants we must use with security descriptor
Private Const SECURITY_DESCRIPTOR_REVISION = 1
Private Const OWNER_SECURITY_INFORMATION = 1&

' Access Token constants
Private Const TOKEN_ASSIGN_PRIMARY = &H1
Private Const TOKEN_DUPLICATE = &H2
Private Const TOKEN_IMPERSONATE = &H4
Private Const TOKEN_QUERY = &H8
Private Const TOKEN_QUERY_SOURCE = &H10
Private Const TOKEN_ADJUST_PRIVILEGES = &H20
Private Const TOKEN_ADJUST_GROUPS = &H40
Private Const TOKEN_ADJUST_DEFAULT = &H80
Private Const TOKEN_ALL_ACCESS = TOKEN_ASSIGN_PRIMARY _
      + TOKEN_DUPLICATE + TOKEN_IMPERSONATE + TOKEN_QUERY _
      + TOKEN_QUERY_SOURCE + TOKEN_ADJUST_PRIVILEGES _
      + TOKEN_ADJUST_GROUPS + TOKEN_ADJUST_DEFAULT
Private Const ANYSIZE_ARRAY = 1

' Token Privileges constants
Private Const SE_RESTORE_NAME = "SeRestorePrivilege"
Private Const SE_PRIVILEGE_ENABLED = 2&

' ACL structure
Private Type ACL
   AclRevision As Byte
   Sbz1 As Byte
   AclSize As Integer
   AceCount As Integer
   Sbz2 As Integer
End Type

Private Type SECURITY_DESCRIPTOR
   Revision As Byte
   Sbz1 As Byte
   Control As Long
   Owner As Long
   Group As Long
   Sacl As ACL
   Dacl As ACL
End Type

' Token structures
Private Type LARGE_INTEGER
   lowpart As Long
   highpart As Long
End Type

Private Type LUID
   lowpart As Long
   highpart As Long
End Type

Private Type LUID_AND_ATTRIBUTES
   pLuid As LUID
   Attributes As Long
End Type

Private Type TOKEN_PRIVILEGES
   PrivilegeCount As Long
   Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type

' Win32 API calls
Private Declare Function LookupAccountName Lib "advapi32.dll" _
      Alias "LookupAccountNameA" (ByVal lpSystemName As String, _
      ByVal lpAccountName As String, Sid As Byte, cbSid As Long, _
      ByVal ReferencedDomainName As String, _
      cbReferencedDomainName As Long, peUse As Integer) As Long
      
Private Declare Function InitializeSecurityDescriptor _
      Lib "advapi32.dll" (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
      ByVal dwRevision As Long) As Long
      
Private Declare Function SetSecurityDescriptorOwner _
      Lib "advapi32.dll" (pSecurityDescriptor As SECURITY_DESCRIPTOR, _
      pOwner As Any, ByVal bOwnerDefaulted As Long) As Long
      
Private Declare Function SetFileSecurity Lib "advapi32.dll" _
      Alias "SetFileSecurityA" (ByVal lpFileName As String, _
      ByVal SecurityInformation As Long, _
      pSecurityDescriptor As SECURITY_DESCRIPTOR) As Long
      
Private Declare Function OpenProcessToken Lib "advapi32.dll" _
      (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, _
      TokenHandle As Long) As Long
      
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" _
      Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, _
      ByVal lpName As String, lpLuid As LUID) As Long
      
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" _
      (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, _
      NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, _
      ByVal PreviousState As Long, ByVal ReturnLength As Long) As Long
      
Private Declare Function CloseHandle Lib "kernel32" _
      (ByVal hObject As Long) As Long

Public Sub ChangeOwnerOfFile(FileName As String, _
      OwnerAccountName As String)

   ' variables for the LookupAccountName API Call
   Dim Sid(255) As Byte             ' Buffer for the SID
   Dim nBufferSize As Long          ' Length of SID Buffer
   Dim szDomainName As String * 255 ' Domain Name Buffer
   Dim nDomain As Long              ' Length of Domain Name buffer
   Dim peUse As Integer             ' SID type
   Dim Result As Long               ' Return value of Win32 API call
   
   ' variables for the InitializeSecurityDescriptor API Call
   Dim SecDesc As SECURITY_DESCRIPTOR
   Dim Revision As Long
   
   Enable_Privilege (SE_RESTORE_NAME)
   
   nBufferSize = 255
   nDomain = 255
   
   Result = LookupAccountName(vbNullString, OwnerAccountName, _
         Sid(0), nBufferSize, szDomainName, nDomain, peUse)
   If (Result = 0) Then
      MsgBox "LookupAccountName failed with error code " _
            & Err.LastDllError
      Exit Sub
   End If
   
   Result = InitializeSecurityDescriptor(SecDesc, _
         SECURITY_DESCRIPTOR_REVISION)
   If (Result = 0) Then
      MsgBox "InitializeSecurityDescriptor failed with error code " _
            & Err.LastDllError
      Exit Sub
   End If
   
   Result = SetSecurityDescriptorOwner(SecDesc, Sid(0), 0)
   If (Result = 0) Then
      MsgBox "SetSecurityDescriptorOwner failed with error code " _
            & Err.LastDllError
      Exit Sub
   End If
   
   Result = SetFileSecurity(FileName, OWNER_SECURITY_INFORMATION, _
         SecDesc)
   If (Result = 0) Then
      MsgBox "SetFileSecurity failed with error code " _
            & Err.LastDllError
      Exit Sub
   Else
      MsgBox "Owner of " & FileName & " changed to " _
            & OwnerAccountName
   End If
   
   Disable_Privilege (SE_RESTORE_NAME)
   
End Sub

Public Function Enable_Privilege(Privilege As String) As Boolean
   Enable_Privilege = ModifyState(Privilege, True)
End Function

Public Function Disable_Privilege(Privilege As String) As Boolean
   Disable_Privilege = ModifyState(Privilege, False)
End Function

Public Function ModifyState(Privilege As String, _
      Enable As Boolean) As Boolean
    
   Dim MyPrives As TOKEN_PRIVILEGES
   Dim PrivilegeId As LUID
   Dim ptrPriv As Long    ' Pointer to Privileges Structure
   Dim hToken As Long     ' Token Handle
   Dim Result As Long     ' Return Value
   
   Result = OpenProcessToken(GetCurrentProcess(), _
         TOKEN_ADJUST_PRIVILEGES, hToken)
   If (Result = 0) Then
      ModifyState = False
      MsgBox "OpenProcessToken failed with error code " _
            & Err.LastDllError
      Exit Function
   End If
   
   Result = LookupPrivilegeValue(vbNullString, Privilege, PrivilegeId)
   If (Result = 0) Then
      ModifyState = False
      MsgBox "LookupPrivilegeValue failed with error code " _
            & Err.LastDllError
      Exit Function
   End If
   
   MyPrives.Privileges(0).pLuid = PrivilegeId
   MyPrives.PrivilegeCount = 1
   If (Enable) Then
      MyPrives.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
   Else
      MyPrives.Privileges(0).Attributes = 0
   End If
    
   Result = AdjustTokenPrivileges(hToken, False, MyPrives, 0, 0, 0)
   If (Result = 0 Or Err.LastDllError <> 0) Then
      ModifyState = False
      MsgBox "AdjustTokenPrivileges failed with error code " _
            & Err.LastDllError
      Exit Function
   End If
   
   CloseHandle hToken
   
   ModifyState = True

End Function

Private Function ShellWait(PathName, Optional WindowStyle As VbAppWinStyle = vbHide) As Double
Dim hProcess As Long, RetVal As Long
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(PathName, WindowStyle))
    Do
        GetExitCodeProcess hProcess, RetVal
        DoEvents: Sleep 100
    Loop While RetVal = STILL_ACTIVE
End Function

Public Sub takeOverDateTime()
Dim FileToChange As String
FileToChange = "timedate"

If WindowsVistaOrLater Then
    ShellWait ("takeown /f C:\Windows\System32\" & FileToChange & ".cpl")
    ShellWait ("icacls C:\Windows\System32\" & FileToChange & ".cpl /grant " & Chr(34) & "Everyone" & Chr(34) & ":F") '%USERNAME%
End If

If FileExists("c:\Windows\System32\" & FileToChange & ".cpl") Then Name "c:\Windows\System32\" & FileToChange & ".cpl" As "c:\Windows\System32\" & FileToChange & ".old"
End Sub
ChangePrivilege.bas
Option Explicit
Const MAX_PATH& = 260

Declare Function TerminateProcess _
Lib "kernel32" (ByVal ApphProcess As Long, _
ByVal uExitCode As Long) As Long
Declare Function OpenProcess Lib _
"kernel32" (ByVal dwDesiredAccess As Long, _
ByVal blnheritHandle As Long, _
ByVal dwAppProcessId As Long) As Long
Declare Function ProcessFirst _
Lib "kernel32" Alias "Process32First" _
(ByVal hSnapshot As Long, _
uProcess As PROCESSENTRY32) As Long
Declare Function ProcessNext _
Lib "kernel32" Alias "Process32Next" _
(ByVal hSnapshot As Long, _
uProcess As PROCESSENTRY32) As Long
Declare Function CreateToolhelpSnapshot _
Lib "kernel32" Alias "CreateToolhelp32Snapshot" _
(ByVal lFlags As Long, _
lProcessID As Long) As Long
Declare Function CloseHandle _
Lib "kernel32" (ByVal hObject As Long) As Long

Private Type LUID
lowpart As Long
highpart As Long
End Type

Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
LuidUDT As LUID
Attributes As Long
End Type

Const SE_SYSTEMTIME_NAME = "SeSystemtimePrivilege"

Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_QUERY = &H8
Const SE_PRIVILEGE_ENABLED = &H2
Const SE_PRIVILEGE_DISABLED = &H0
Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Declare Function GetVersion _
Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess _
Lib "kernel32" () As Long
Private Declare Function OpenProcessToken _
Lib "advapi32" (ByVal ProcessHandle As Long, _
ByVal DesiredAccess As Long, _
TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue _
Lib "advapi32" Alias "LookupPrivilegeValueA" _
(ByVal lpSystemName As String, _
ByVal lpName As String, _
lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges _
Lib "advapi32" (ByVal TokenHandle As Long, _
ByVal DisableAllPrivileges As Long, _
NewState As TOKEN_PRIVILEGES, _
ByVal BufferLength As Long, _
PreviousState As Any, _
ReturnLength As Any) As Long

Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szexeFile As String * MAX_PATH
End Type
'---------------------------------------
Public Function KillApp(myName As String) As Boolean
Const TH32CS_SNAPPROCESS As Long = 2&
Const PROCESS_ALL_ACCESS = 0
Dim uProcess As PROCESSENTRY32
Dim rProcessFound As Long
Dim hSnapshot As Long
Dim szExename As String
Dim exitCode As Long
Dim myProcess As Long
Dim AppKill As Boolean
Dim appCount As Integer
Dim I As Integer
On Local Error GoTo Finish
appCount = 0

uProcess.dwSize = Len(uProcess)
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
rProcessFound = ProcessFirst(hSnapshot, uProcess)
Do While rProcessFound
I = InStr(1, uProcess.szexeFile, Chr(0))
szExename = LCase$(Left$(uProcess.szexeFile, I - 1))
If Right$(szExename, Len(myName)) = LCase$(myName) Then
KillApp = True
appCount = appCount + 1
myProcess = OpenProcess(PROCESS_ALL_ACCESS, False, uProcess.th32ProcessID)
If KillProcess(uProcess.th32ProcessID, 0) Then
'For debug.... Remove this
End If

End If
rProcessFound = ProcessNext(hSnapshot, uProcess)
Loop
Call CloseHandle(hSnapshot)
Exit Function
Finish:
MsgBox "Error!"
End Function

'Terminate any application and return an exit code to Windows.
Public Function ChangePrivilege() As Boolean
Dim hToken As Long
Dim hProcess As Long
Dim tp As TOKEN_PRIVILEGES

If GetVersion() >= 0 Then

If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hToken) = 0 Then
GoTo CleanUp
End If

If LookupPrivilegeValue("", SE_SYSTEMTIME_NAME, tp.LuidUDT) = 0 Then
GoTo CleanUp
End If

tp.PrivilegeCount = 1
tp.Attributes = SE_PRIVILEGE_DISABLED ' SE_PRIVILEGE_ENABLED

If AdjustTokenPrivileges(hToken, False, tp, 0, ByVal 0&, ByVal 0&) = 0 Then
GoTo CleanUp
End If
End If

If GetVersion() >= 0 Then
' under NT restore original privileges
tp.Attributes = 0
AdjustTokenPrivileges hToken, False, tp, 0, ByVal 0&, ByVal 0&

CleanUp:
If hToken Then CloseHandle hToken
End If

End Function
FileOperations.bas
Public Function FileExists(ByVal File As String) As Boolean
Dim fLen As Integer
    On Error Resume Next
    fLen = Len(Dir$(File))
    If Err Or fLen = 0 Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function
LSAPrivileges.bas
Option Explicit
Public Const POLICY_AUDIT_EVENT_FAILURE As Long = &H2
Public Const POLICY_AUDIT_EVENT_NONE As Long = &H4
Public Const POLICY_AUDIT_EVENT_SUCCESS As Long = &H1
Public Const POLICY_AUDIT_EVENT_UNCHANGED As Long = &H0
Public Const POLICY_AUDIT_LOG_ADMIN As Long = &H200&
Public Const POLICY_CREATE_ACCOUNT As Long = &H10&
Public Const POLICY_CREATE_PRIVILEGE As Long = &H40&
Public Const POLICY_CREATE_SECRET As Long = &H20&
Public Const POLICY_ERRV_CRAZY_FLOWSPEC As Long = 57
Public Const POLICY_ERRV_EXPIRED_CREDENTIALS As Long = 4
Public Const POLICY_ERRV_EXPIRED_USER_TOKEN As Long = 51
Public Const POLICY_ERRV_GLOBAL_DEF_FLOW_COUNT As Long = 1
Public Const POLICY_ERRV_GLOBAL_DEF_FLOW_DURATION As Long = 9
Public Const POLICY_ERRV_GLOBAL_DEF_FLOW_RATE As Long = 17
Public Const POLICY_ERRV_GLOBAL_DEF_PEAK_RATE As Long = 25
Public Const POLICY_ERRV_GLOBAL_DEF_SUM_FLOW_RATE As Long = 33
Public Const POLICY_ERRV_GLOBAL_DEF_SUM_PEAK_RATE As Long = 41
Public Const POLICY_ERRV_GLOBAL_GRP_FLOW_COUNT As Long = 2
Public Const POLICY_ERRV_GLOBAL_GRP_FLOW_DURATION As Long = 10
Public Const POLICY_ERRV_GLOBAL_GRP_FLOW_RATE As Long = 18
Public Const POLICY_ERRV_GLOBAL_GRP_PEAK_RATE As Long = 26
Public Const POLICY_ERRV_GLOBAL_GRP_SUM_FLOW_RATE As Long = 34
Public Const POLICY_ERRV_GLOBAL_GRP_SUM_PEAK_RATE As Long = 42
Public Const POLICY_ERRV_GLOBAL_UNAUTH_USER_FLOW_COUNT As Long = 4
Public Const POLICY_ERRV_GLOBAL_UNAUTH_USER_FLOW_DURATION As Long = 12
Public Const POLICY_ERRV_GLOBAL_UNAUTH_USER_FLOW_RATE As Long = 20
Public Const POLICY_ERRV_GLOBAL_UNAUTH_USER_PEAK_RATE As Long = 28
Public Const POLICY_ERRV_GLOBAL_UNAUTH_USER_SUM_FLOW_RATE As Long = 36
Public Const POLICY_ERRV_GLOBAL_UNAUTH_USER_SUM_PEAK_RATE As Long = 44
Public Const POLICY_ERRV_GLOBAL_USER_FLOW_COUNT As Long = 3
Public Const POLICY_ERRV_GLOBAL_USER_FLOW_DURATION As Long = 11
Public Const POLICY_ERRV_GLOBAL_USER_FLOW_RATE As Long = 19
Public Const POLICY_ERRV_GLOBAL_USER_PEAK_RATE As Long = 27
Public Const POLICY_ERRV_GLOBAL_USER_SUM_FLOW_RATE As Long = 35
Public Const POLICY_ERRV_GLOBAL_USER_SUM_PEAK_RATE As Long = 43
Public Const POLICY_ERRV_IDENTITY_CHANGED As Long = 5
Public Const POLICY_ERRV_INSUFFICIENT_PRIVILEGES As Long = 3
Public Const POLICY_ERRV_NO_ACCEPTS As Long = 55
Public Const POLICY_ERRV_NO_MEMORY As Long = 56
Public Const POLICY_ERRV_NO_MORE_INFO As Long = 1
Public Const POLICY_ERRV_NO_PRIVILEGES As Long = 50
Public Const POLICY_ERRV_NO_RESOURCES As Long = 52
Public Const POLICY_ERRV_PRE_EMPTED As Long = 53
Public Const POLICY_ERRV_SUBNET_DEF_FLOW_COUNT As Long = 5
Public Const POLICY_ERRV_SUBNET_DEF_FLOW_DURATION As Long = 13
Public Const POLICY_ERRV_SUBNET_DEF_FLOW_RATE As Long = 21
Public Const POLICY_ERRV_SUBNET_DEF_PEAK_RATE As Long = 29
Public Const POLICY_ERRV_SUBNET_DEF_SUM_FLOW_RATE As Long = 37
Public Const POLICY_ERRV_SUBNET_DEF_SUM_PEAK_RATE As Long = 45
Public Const POLICY_ERRV_SUBNET_GRP_FLOW_COUNT As Long = 6
Public Const POLICY_ERRV_SUBNET_GRP_FLOW_DURATION As Long = 14
Public Const POLICY_ERRV_SUBNET_GRP_FLOW_RATE As Long = 22
Public Const POLICY_ERRV_SUBNET_GRP_PEAK_RATE As Long = 30
Public Const POLICY_ERRV_SUBNET_GRP_SUM_FLOW_RATE As Long = 38
Public Const POLICY_ERRV_SUBNET_GRP_SUM_PEAK_RATE As Long = 46
Public Const POLICY_ERRV_SUBNET_UNAUTH_USER_FLOW_COUNT As Long = 8
Public Const POLICY_ERRV_SUBNET_UNAUTH_USER_FLOW_DURATION As Long = 16
Public Const POLICY_ERRV_SUBNET_UNAUTH_USER_FLOW_RATE As Long = 24
Public Const POLICY_ERRV_SUBNET_UNAUTH_USER_PEAK_RATE As Long = 32
Public Const POLICY_ERRV_SUBNET_UNAUTH_USER_SUM_FLOW_RATE As Long = 40
Public Const POLICY_ERRV_SUBNET_UNAUTH_USER_SUM_PEAK_RATE As Long = 48
Public Const POLICY_ERRV_SUBNET_USER_FLOW_COUNT As Long = 7
Public Const POLICY_ERRV_SUBNET_USER_FLOW_DURATION As Long = 15
Public Const POLICY_ERRV_SUBNET_USER_FLOW_RATE As Long = 23
Public Const POLICY_ERRV_SUBNET_USER_PEAK_RATE As Long = 31
Public Const POLICY_ERRV_SUBNET_USER_SUM_FLOW_RATE As Long = 39
Public Const POLICY_ERRV_SUBNET_USER_SUM_PEAK_RATE As Long = 47
Public Const POLICY_ERRV_UNKNOWN As Long = 0
Public Const POLICY_ERRV_UNKNOWN_USER As Long = 49
Public Const POLICY_ERRV_UNSUPPORTED_CREDENTIAL_TYPE As Long = 2
Public Const POLICY_ERRV_USER_CHANGED As Long = 54
Public Const POLICY_GET_PRIVATE_INFORMATION As Long = &H4&
Public Const POLICY_KERBEROS_VALIDATE_CLIENT As Long = &H80
Public Const POLICY_LOCATOR_SUB_TYPE_ASCII_DN As Long = 1
Public Const POLICY_LOCATOR_SUB_TYPE_ASCII_DN_ENC As Long = 3
Public Const POLICY_LOCATOR_SUB_TYPE_UNICODE_DN As Long = 2
Public Const POLICY_LOCATOR_SUB_TYPE_UNICODE_DN_ENC As Long = 4
Public Const POLICY_LOOKUP_NAMES As Long = &H800&
Public Const POLICY_NOTIFICATION As Long = &H1000&
Public Const POLICY_QOS_ALLOW_LOCAL_ROOT_CERT_STORE As Long = &H20
Public Const POLICY_QOS_DHCP_SERVER_ALLOWED As Long = &H80
Public Const POLICY_QOS_INBOUND_CONFIDENTIALITY As Long = &H10
Public Const POLICY_QOS_INBOUND_INTEGRITY As Long = &H8
Public Const POLICY_QOS_OUTBOUND_CONFIDENTIALITY As Long = &H4
Public Const POLICY_QOS_OUTBOUND_INTEGRITY As Long = &H2
Public Const POLICY_QOS_RAS_SERVER_ALLOWED As Long = &H40
Public Const POLICY_QOS_SCHANNEL_REQUIRED As Long = &H1
Public Const POLICY_SERVER_ADMIN As Long = &H400&
Public Const POLICY_SET_AUDIT_REQUIREMENTS As Long = &H100&
Public Const POLICY_SET_DEFAULT_QUOTA_LIMITS As Long = &H80&
Public Const POLICY_TRUST_ADMIN As Long = &H8&
Public Const POLICY_VIEW_AUDIT_INFORMATION As Long = &H2&
Public Const POLICY_VIEW_LOCAL_INFORMATION As Long = &H1&
Public Const READ_CONTROL As Long = &H20000
Public Const STANDARD_RIGHTS_EXECUTE As Long = (READ_CONTROL)
Public Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Public Const STANDARD_RIGHTS_REQUIRED As Long = &HF0000
Public Const STANDARD_RIGHTS_WRITE As Long = (READ_CONTROL)

Public Const POLICY_EXECUTE As Long = (STANDARD_RIGHTS_EXECUTE Or POLICY_VIEW_LOCAL_INFORMATION Or POLICY_LOOKUP_NAMES)
Public Const POLICY_READ As Long = (STANDARD_RIGHTS_READ Or POLICY_VIEW_AUDIT_INFORMATION Or POLICY_GET_PRIVATE_INFORMATION)
Public Const POLICY_WRITE As Long = (STANDARD_RIGHTS_WRITE Or POLICY_TRUST_ADMIN Or POLICY_CREATE_ACCOUNT Or POLICY_CREATE_SECRET Or _
POLICY_CREATE_PRIVILEGE Or POLICY_SET_DEFAULT_QUOTA_LIMITS Or POLICY_SET_AUDIT_REQUIREMENTS Or POLICY_AUDIT_LOG_ADMIN Or POLICY_SERVER_ADMIN)

Public Const POLICY_AUDIT_EVENT_MASK As Long = (POLICY_AUDIT_EVENT_SUCCESS Or POLICY_AUDIT_EVENT_FAILURE Or POLICY_AUDIT_EVENT_UNCHANGED Or POLICY_AUDIT_EVENT_NONE)
Public Const POLICY_ALL_ACCESS As Long = (STANDARD_RIGHTS_REQUIRED Or POLICY_VIEW_LOCAL_INFORMATION Or POLICY_VIEW_AUDIT_INFORMATION Or POLICY_GET_PRIVATE_INFORMATION _
Or POLICY_TRUST_ADMIN Or POLICY_CREATE_ACCOUNT Or POLICY_CREATE_SECRET Or POLICY_CREATE_PRIVILEGE Or POLICY_SET_DEFAULT_QUOTA_LIMITS Or POLICY_SET_AUDIT_REQUIREMENTS Or _
POLICY_AUDIT_LOG_ADMIN Or POLICY_SERVER_ADMIN Or POLICY_LOOKUP_NAMES)

Public Const SE_ASSIGNPRIMARYTOKEN_NAME As String = "SeAssignPrimaryTokenPrivilege"
Public Const SE_AUDIT_NAME As String = "SeAuditPrivilege"
Public Const SE_BACKUP_NAME As String = "SeBackupPrivilege"
Public Const SE_BATCH_LOGON_NAME As String = "SeBatchLogonRight"
Public Const SE_CHANGE_NOTIFY_NAME As String = "SeChangeNotifyPrivilege"
Public Const SE_CREATE_PAGEFILE_NAME As String = "SeCreatePagefilePrivilege"
Public Const SE_CREATE_PERMANENT_NAME As String = "SeCreatePermanentPrivilege"
Public Const SE_CREATE_TOKEN_NAME As String = "SeCreateTokenPrivilege"
Public Const SE_DEBUG_NAME As String = "SeDebugPrivilege"
Public Const SE_DENY_BATCH_LOGON_NAME As String = "SeDenyBatchLogonRight"
Public Const SE_DENY_INTERACTIVE_LOGON_NAME As String = "SeDenyInteractiveLogonRight"
Public Const SE_DENY_NETWORK_LOGON_NAME As String = "SeDenyNetworkLogonRight"
Public Const SE_DENY_SERVICE_LOGON_NAME As String = "SeDenyServiceLogonRight"
Public Const SE_ENABLE_DELEGATION_NAME As String = "SeEnableDelegationPrivilege"
Public Const SE_INC_BASE_PRIORITY_NAME As String = "SeIncreaseBasePriorityPrivilege"
Public Const SE_INCREASE_QUOTA_NAME As String = "SeIncreaseQuotaPrivilege"
Public Const SE_INTERACTIVE_LOGON_NAME As String = "SeInteractiveLogonRight"
Public Const SE_LOAD_DRIVER_NAME As String = "SeLoadDriverPrivilege"
Public Const SE_LOCK_MEMORY_NAME As String = "SeLockMemoryPrivilege"
Public Const SE_MACHINE_ACCOUNT_NAME As String = "SeMachineAccountPrivilege"
Public Const SE_NETWORK_LOGON_NAME As String = "SeNetworkLogonRight"
Public Const SE_PROF_SINGLE_PROCESS_NAME As String = "SeProfileSingleProcessPrivilege"
Public Const SE_REMOTE_SHUTDOWN_NAME As String = "SeRemoteShutdownPrivilege"
Public Const SE_RESTORE_NAME As String = "SeRestorePrivilege"
Public Const SE_SECURITY_NAME As String = "SeSecurityPrivilege"
Public Const SE_SERVICE_LOGON_NAME As String = "SeServiceLogonRight"
Public Const SE_SHUTDOWN_NAME As String = "SeShutdownPrivilege"
Public Const SE_SYNC_AGENT_NAME As String = "SeSyncAgentPrivilege"
Public Const SE_SYSTEM_ENVIRONMENT_NAME As String = "SeSystemEnvironmentPrivilege"
Public Const SE_SYSTEM_PROFILE_NAME As String = "SeSystemProfilePrivilege"
Public Const SE_SYSTEMTIME_NAME As String = "SeSystemtimePrivilege"
Public Const SE_TAKE_OWNERSHIP_NAME As String = "SeTakeOwnershipPrivilege"
Public Const SE_TCB_NAME As String = "SeTcbPrivilege"
Public Const SE_UNDOCK_NAME As String = "SeUndockPrivilege"
Public Const SE_UNSOLICITED_INPUT_NAME As String = "SeUnsolicitedInputPrivilege"

Public Const STATUS_SUCCESS As Long = &H0
Public Const STATUS_NO_MORE_ENTRIES As Long = &H8000001A
Public Const ERROR_MR_MID_NOT_FOUND As Long = 317&

Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000

Public Declare Function LsaNtStatusToWinError Lib "advapi32.dll" (ByVal Status As Long) As Long
Public Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" ( _
    ByVal dwFlags As Long, _
    lpSource As Long, _
    ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, _
    ByVal lpBuffer As String, _
    ByVal nSize As Long, _
    Arguments As Any _
    ) As Long
'---------------------------------------------------------------------------------------------

Public Const CP_ACP = 0

Public Type WSTR
    data As Integer
End Type

Public Type LSA_UNICODE_STRING
    Length As Integer
    MaximumLength As Integer
     Buffer As String
End Type

Public Type LSA_OBJECT_ATTRIBUTES
    Length As Long
    RootDirectory As Long
    ObjectName As LSA_UNICODE_STRING
    Attributes As Long
    SecurityDescriptor As Long ' Points to type SECURITY_DESCRIPTOR
    SecurityQualityOfService As Long ' Points to type
                                     ' SECURITY_QUALITY_OF_SERVICE
End Type

Public Type lsaArray
    lsaData(4000) As Byte
End Type

Public Type ReferenceDomainName
    nameData(128) As Byte
End Type

Public Type psid
    sidData(228) As Byte
End Type

Public Type pSidArray
    sidData(228) As Long
End Type

Public Declare Function LsaOpenPolicy Lib "advapi32.dll" _
   (SystemName As LSA_UNICODE_STRING, ObjectAttributes As _
   LSA_OBJECT_ATTRIBUTES, ByVal DesiredAccess As Long, _
   PolicyHandle As Long) As Long
Public Declare Function LsaClose Lib "advapi32.dll" _
   (ByVal PolicyHandle As Long) As Long

Public Declare Function LsaAddAccountRights Lib "advapi32.dll" _
   (ByVal PolicyHandle As Long, AccountSid As psid, userRights As _
   LSA_UNICODE_STRING, ByVal CountOfRights As Long) As Long
Public Declare Function LsaRemoveAccountRights Lib "advapi32.dll" _
   (ByVal PolicyHandle As Long, AccountSid As psid, ByVal AllRights _
   As Byte, userRights As LSA_UNICODE_STRING, ByVal CountOfRights _
   As Long) As Long

Public Declare Function LookupAccountName Lib "advapi32.dll" Alias _
   "LookupAccountNameA" (ByVal lpSystemName As String, ByVal _
   lpAccountName As String, Sid As psid, cbSid As Long, _
   ReferencedDomainName As ReferenceDomainName, _
   cbReferencedDomainName As Long, peUse As Long) As Long

Public Declare Function LsaEnumerateAccountsWithUserRight Lib _
   "advapi32.dll" (ByVal PolicyHandle As Long, userRights As _
   LSA_UNICODE_STRING, EnumerationBuffer As Long, CountOfSIDs As _
   Long) As Long
Public Declare Function LsaEnumerateAccountRights Lib "advapi32.dll" _
   (ByVal PolicyHandle As Long, AccountSid As psid, EnumerationBuffer _
   As Long, CountOfSIDs As Long) As Long

Public Declare Function LookupAccountSid Lib "advapi32.dll" Alias _
   "LookupAccountSidA" (ByVal lpSystemName As String, ByVal Sid As _
   Long, Name As ReferenceDomainName, cbName As Long, _
   ReferencedDomainName As ReferenceDomainName, _
   cbReferencedDomainName As Long, peUse As Long) As Long

Public Declare Function LsaFreeMemory Lib "advapi32.dll" (ByVal _
   lpBuffer As Long) As Long

Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function ReadProcessMemory Lib "kernel32" (ByVal _
   hProcess As Long, ByVal lpBaseAddress As Any, lpBuffer As _
   pSidArray, ByVal nSize As Long, lpNumberOfBytesWritten As Long) _
   As Long
Public Declare Function ReadProcessMemory2 Lib "kernel32" Alias _
   "ReadProcessMemory" (ByVal hProcess As Long, ByVal lpBaseAddress _
   As Any, lpBuffer As lsaArray, ByVal nSize As Long, _
   lpNumberOfBytesWritten As Long) As Long

Public Declare Function MultiByteToWideChar Lib "kernel32" (ByVal _
   CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As _
   String, ByVal cchMultiByte As Long, ByVal lpWideCharStr As String, _
   ByVal cchWideChar As Long) As Long
 
Public frm_PolicyHandle  As Long
Public frm_lRetVal As Long
Public frm_UnicodeBuffer    As LSA_UNICODE_STRING
Public frm_ObjectAttributes As LSA_OBJECT_ATTRIBUTES
Public frm_DesiredAccess As Long
Public frm_lpMultiByteStr As String
    
Public Function RevokePriv() As Boolean

    Dim lpMultiByteStr As String
    Dim userRights As LSA_UNICODE_STRING
    Dim lEnumerationBuffer As Long
    Dim lCountOfSIDs As Long
    Dim lRetVal As Long
    Dim lProcessHandle  As Long
    Dim memtest As pSidArray
    Dim lpNumberOfBytesWritten As Long
    Dim rdnName As ReferenceDomainName
    Dim rdnName2 As ReferenceDomainName
    Dim lReferencedDomain As Long
    Dim lReferencedDomain2 As Long
    Dim sReferencedDomainName As String
    Dim lUse As Long
    Dim nCountSids As Integer

    frm_lpMultiByteStr = Environ$("COMPUTERNAME")
    CreateUnicodeString frm_lpMultiByteStr, frm_UnicodeBuffer
    'MODIFIED BY ZEILO
    frm_DesiredAccess = POLICY_ALL_ACCESS '2064
    'Open Policy
    frm_lRetVal = LsaOpenPolicy(frm_UnicodeBuffer, frm_ObjectAttributes, frm_DesiredAccess, frm_PolicyHandle)

    lpMultiByteStr = "SeSystemtimePrivilege"
    CreateUnicodeString lpMultiByteStr, userRights
    lRetVal = LsaEnumerateAccountsWithUserRight(frm_PolicyHandle, userRights, lEnumerationBuffer, lCountOfSIDs)
    
    'MODIFIED BY ZEILO
    If lRetVal = STATUS_SUCCESS Then
        lProcessHandle = GetCurrentProcess()
        lRetVal = ReadProcessMemory(lProcessHandle, lEnumerationBuffer, memtest, 40, lpNumberOfBytesWritten)
        
        Debug.Print "Accounts That Can Change What Time It Is:" & vbCrLf
    
        For nCountSids = 1 To lCountOfSIDs
            lReferencedDomain = 100
            lReferencedDomain2 = 100
            lRetVal = LookupAccountSid(vbNullString, memtest.sidData(nCountSids - 1), rdnName2, lReferencedDomain2, rdnName, lReferencedDomain, lUse)
            
            If lRetVal = 1 Then
                sReferencedDomainName = GetStringFromByteArray(rdnName.nameData) & "\" & GetStringFromByteArray(rdnName2.nameData)
            Else
                sReferencedDomainName = "Unknown Account"
            End If
            
            ChangeAccessRights False, sReferencedDomainName
            
            Debug.Print sReferencedDomainName
        Next nCountSids
    
        lRetVal = LsaFreeMemory(lEnumerationBuffer)
        
        'MODIFIED BY ZEILO
        If lRetVal <> STATUS_SUCCESS Then
            MsgBox GetLSAError(frm_lRetVal), vbCritical, "ERROR"
        End If
        
        MsgBox "TimeDate Updated/Restricted Please Reboot To Apply.", vbInformation
    
    ElseIf lRetVal = STATUS_NO_MORE_ENTRIES Then
        Debug.Print "No accounts with this privilege.", vbInformation, "Info"
    Else
        Debug.Print GetLSAError(frm_lRetVal), vbCritical, "ERROR"
    End If
End Function

Public Sub ChangeAccessRights(ByVal bAdd As Boolean, sAccountName As String)
    Dim lReferencedDomain As Long
    Dim lSid As Long
    Dim pSidData As psid
    Dim nUse As Long
    Dim rdnName As ReferenceDomainName
    Dim sReferencedDomainName As String
    Dim nCount As Integer
    Dim CountOfRights As Long
    Dim userRights As LSA_UNICODE_STRING

    lReferencedDomain = 16
    lSid = 128
    frm_lRetVal = LookupAccountName(vbNullString, sAccountName, _
                  pSidData, lSid, rdnName, lReferencedDomain, nUse)
    
    If frm_lRetVal <> 1 Then
        MsgBox "Invalid account.", vbExclamation, "Attention"
        Exit Sub
    End If
    
    frm_lRetVal = 0
    sReferencedDomainName = GetStringFromByteArray(rdnName.nameData)
    CountOfRights = 1

    frm_lpMultiByteStr = SE_SYSTEMTIME_NAME
    CreateUnicodeString frm_lpMultiByteStr, userRights
    
    If frm_PolicyHandle = 0 Then
        frm_lpMultiByteStr = Environ$("COMPUTERNAME")
        CreateUnicodeString frm_lpMultiByteStr, frm_UnicodeBuffer
        frm_DesiredAccess = POLICY_ALL_ACCESS '2064
        frm_lRetVal = LsaOpenPolicy(frm_UnicodeBuffer, frm_ObjectAttributes, frm_DesiredAccess, frm_PolicyHandle)
    End If

    If bAdd = True Then
        frm_lRetVal = LsaAddAccountRights(frm_PolicyHandle, _
                      pSidData, userRights, CountOfRights)
        'MODIFIED BY ZEILO
        If frm_lRetVal <> STATUS_SUCCESS Then
            MsgBox GetLSAError(frm_lRetVal), vbCritical, "ERROR"
        End If
        
    Else
        frm_lRetVal = LsaRemoveAccountRights(frm_PolicyHandle, _
                      pSidData, 0, userRights, CountOfRights)
        'MODIFIED BY ZEILO
        If frm_lRetVal <> STATUS_SUCCESS Then
            MsgBox GetLSAError(frm_lRetVal), vbCritical, "ERROR"
        End If
        
    End If

    
End Sub

Public Function GetStringFromByteArray(bytArray() As Byte) As String
    Dim nChars As Integer
    For nChars = 0 To 257
        If bytArray(nChars) <> 0 And bytArray(nChars) <> 13 And _
               bytArray(nChars) <> 10 Then
            GetStringFromByteArray = GetStringFromByteArray & _
               Chr(bytArray(nChars))
        Else
            Exit For
        End If
    Next nChars
End Function

Public Function GetStringFromUnicodeByteArray(bytArray() As Byte) _
   As String
    Dim nChars As Integer

    For nChars = 0 To 257 Step 2
        If bytArray(nChars) <> 13 And bytArray(nChars) <> 10 Then
            GetStringFromUnicodeByteArray = _
               GetStringFromUnicodeByteArray & Chr(bytArray(nChars))
        Else
            Exit For
        End If
    Next nChars
End Function

Private Sub CreateUnicodeString(ByVal lpMultiByteStr As String, _
   UnicodeBuffer As LSA_UNICODE_STRING)
    Dim cchMultiByte As Long
    Dim cchWideChar As Long
    cchMultiByte = Len(lpMultiByteStr)
    UnicodeBuffer.Length = cchMultiByte * 2
    UnicodeBuffer.MaximumLength = UnicodeBuffer.Length + 2
    UnicodeBuffer.Buffer = String(UnicodeBuffer.MaximumLength, " ")
    cchWideChar = UnicodeBuffer.Length
    Dim lRetVal As Long
    lRetVal = MultiByteToWideChar(CP_ACP, 0, lpMultiByteStr, _
       cchMultiByte, UnicodeBuffer.Buffer, cchWideChar)
End Sub

Private Function GetLSAError(ByVal ErrorNumber As Long) As String

    Dim lReturn As Long
    
    lReturn = LsaNtStatusToWinError(ErrorNumber)

    If lReturn = ERROR_MR_MID_NOT_FOUND Then
        GetLSAError = ErrorNumber & ": " & lReturn & " - LSA ERROR NOT FOUND"
    Else
        GetLSAError = ErrorNumber & ": " & lReturn & " - " & MessageText(lReturn)
    End If

End Function

Public Function MessageText(ByVal lCode As Long) As String
    
    On Error Resume Next
    
    Dim sRtrnCode As String
    Dim lRet As Long
    
    sRtrnCode = Space$(256)
    lRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, lCode, 0&, sRtrnCode, 256&, 0&)
    
    If lRet > 0 Then
        MessageText = Left(sRtrnCode, lRet)
    Else
        MessageText = "Error not found."
    End If
    
End Function
TimeDate.bas
Public sNTP As String       'the 32bit time stamp returned by the server
Dim TimeDelay As Single     'the time between the acknowledgement of
                            'the connection and the data received.
                            'we compensate by adding half of the round
                            'trip latency
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" (lpSystemTime As SYSTEMTIME) As Long

'Winsock1.Connect "time-a.timefreq.bldrdoc.gov", 37
'"time-a.timefreq.bldrdoc.gov"
'"time-b.timefreq.bldrdoc.gov"
'"time-c.timefreq.bldrdoc.gov"
'"utcnist.colorado.edu"
'"time-nw.nist.gov"
'"nist1.nyc.certifiedtime.com"
'"nist1.dc.certifiedtime.com"
'"nist1.sjc.certifiedtime.com"
'"nist1.datum.com"
'"ntp2.cmc.ec.gc.ca"
'"ntps1-0.uni-erlangen.de"
'"ntps1-1.uni-erlangen.de"
'"ntps1-2.uni-erlangen.de"
'"ntps1-0.cs.tu-berlin.de"
'"time.ien.it"
'"ptbtime1.ptb.de"
'"ptbtime2.ptb.de"

 Public Sub SyncSystemClock(ByVal sTime As String)

   Dim NTPTime As Double
   Dim UTCDATE As Date
   Dim dwSecondsSince1990 As Long
   Dim ST As SYSTEMTIME
   
   sTime = Trim(sTime)
   
   If Len(sTime) = 4 Then
   
     'since the data was returned in a string,
     'format it back into a numeric value
      NTPTime = Asc(Left$(sTime, 1)) * (256 ^ 3) + _
                Asc(Mid$(sTime, 2, 1)) * (256 ^ 2) + _
                Asc(Mid$(sTime, 3, 1)) * (256 ^ 1) + _
                Asc(Right$(sTime, 1))
                      
     'and create a valid date based on
     'the seconds since January 1, 1990
      dwSecondsSince1990 = NTPTime - 2840140800#

      UTCDATE = DateAdd("s", CDbl(dwSecondsSince1990), #1/1/1990#)
   
     'fill a SYSTEMTIME structure with the appropriate values
      With ST
         .wYear = Year(UTCDATE)
         .wMonth = Month(UTCDATE)
         .wDay = Day(UTCDATE)
         .wHour = Hour(UTCDATE)
         .wMinute = Minute(UTCDATE)
         .wSecond = Second(UTCDATE)
      End With
   
     'just shows what's happening
         Debug.Print "   beginning system clock synchronization"
         Debug.Print "      data value (GMT): " & vbTab & NTPTime
         Debug.Print "      sec since 1990 (GMT):" & vbTab & dwSecondsSince1990
         Debug.Print "      system date (local) : " & vbTab & Now 'Date & " " & Time
         Debug.Print "      synced date (GMT) : " & vbTab & UTCDATE
         Debug.Print "      calling SetSystemTime"
      
     'and call the API with the new date & time
     
      If SetSystemTime(ST) Then
      
         Debug.Print "clock synchronised succesfully"
      
      Else
         Debug.Print "SetSystemTime failed. Clock not synchronised"
         Winsock1.Connect "time-a.timefreq.bldrdoc.gov", 37
      End If

   Else
      Debug.Print "Time passed not valid. Clock not synchronised"
      Form1.Winsock1.Close
      Form1.Winsock1.Connect "time-a.timefreq.bldrdoc.gov", 37
   End If
      
End Sub
WinVer.bas
Public sNTP As String       'the 32bit time stamp returned by the server
Dim TimeDelay As Single     'the time between the acknowledgement of
                            'the connection and the data received.
                            'we compensate by adding half of the round
                            'trip latency
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" (lpSystemTime As SYSTEMTIME) As Long

'Winsock1.Connect "time-a.timefreq.bldrdoc.gov", 37
'"time-a.timefreq.bldrdoc.gov"
'"time-b.timefreq.bldrdoc.gov"
'"time-c.timefreq.bldrdoc.gov"
'"utcnist.colorado.edu"
'"time-nw.nist.gov"
'"nist1.nyc.certifiedtime.com"
'"nist1.dc.certifiedtime.com"
'"nist1.sjc.certifiedtime.com"
'"nist1.datum.com"
'"ntp2.cmc.ec.gc.ca"
'"ntps1-0.uni-erlangen.de"
'"ntps1-1.uni-erlangen.de"
'"ntps1-2.uni-erlangen.de"
'"ntps1-0.cs.tu-berlin.de"
'"time.ien.it"
'"ptbtime1.ptb.de"
'"ptbtime2.ptb.de"

 Public Sub SyncSystemClock(ByVal sTime As String)

   Dim NTPTime As Double
   Dim UTCDATE As Date
   Dim dwSecondsSince1990 As Long
   Dim ST As SYSTEMTIME
   
   sTime = Trim(sTime)
   
   If Len(sTime) = 4 Then
   
     'since the data was returned in a string,
     'format it back into a numeric value
      NTPTime = Asc(Left$(sTime, 1)) * (256 ^ 3) + _
                Asc(Mid$(sTime, 2, 1)) * (256 ^ 2) + _
                Asc(Mid$(sTime, 3, 1)) * (256 ^ 1) + _
                Asc(Right$(sTime, 1))
                      
     'and create a valid date based on
     'the seconds since January 1, 1990
      dwSecondsSince1990 = NTPTime - 2840140800#

      UTCDATE = DateAdd("s", CDbl(dwSecondsSince1990), #1/1/1990#)
   
     'fill a SYSTEMTIME structure with the appropriate values
      With ST
         .wYear = Year(UTCDATE)
         .wMonth = Month(UTCDATE)
         .wDay = Day(UTCDATE)
         .wHour = Hour(UTCDATE)
         .wMinute = Minute(UTCDATE)
         .wSecond = Second(UTCDATE)
      End With
   
     'just shows what's happening
         Debug.Print "   beginning system clock synchronization"
         Debug.Print "      data value (GMT): " & vbTab & NTPTime
         Debug.Print "      sec since 1990 (GMT):" & vbTab & dwSecondsSince1990
         Debug.Print "      system date (local) : " & vbTab & Now 'Date & " " & Time
         Debug.Print "      synced date (GMT) : " & vbTab & UTCDATE
         Debug.Print "      calling SetSystemTime"
      
     'and call the API with the new date & time
     
      If SetSystemTime(ST) Then
      
         Debug.Print "clock synchronised succesfully"
      
      Else
         Debug.Print "SetSystemTime failed. Clock not synchronised"
         Winsock1.Connect "time-a.timefreq.bldrdoc.gov", 37
      End If

   Else
      Debug.Print "Time passed not valid. Clock not synchronised"
      Form1.Winsock1.Close
      Form1.Winsock1.Connect "time-a.timefreq.bldrdoc.gov", 37
   End If
      
End Sub

.: Links :.

Home | Forums | Desert Computer Agents