| |
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
|
|