codice:
Option Explicit
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(0 To 0) As LUID_AND_ATTRIBUTES
End Type
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' string per PSS
End Type
Public Enum EShutDownTypes
[_First] = 0
EWX_LOGOFF = 0
EWX_SHUTDOWN = 1&
EWX_REBOOT = 2&
EWX_FORCE = 4&
EWX_POWEROFF = 8&
EWX_FORCEIFHUNG = 10& ' NT5
EWX_RESET = EWX_LOGOFF Or EWX_FORCE Or EWX_REBOOT
[_Last] = &H20& - 1
End Enum
Public Enum EShutDownErrorBaseConstant
eeSSDErrorBase = vbObjectError Or (1048 + &H210)
End Enum
Private Declare Function GetCurrentProcess Lib "kernel32" () 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 CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetTokenInformation Lib "advapi32.dll" _
(ByVal TokenHandle As Long, TokenInformationClass As Integer, _
TokenInformation As Any, ByVal TokenInformationLength As Long, _
ReturnLength As Long) 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, _
PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) 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 ExitWindowsEx Lib "user32" _
(ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function FormatMessage Lib "kernel32" _
Alias "FormatMessageA" _
(ByVal dwFlags As Long, lpSource As Any, _
ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, ByVal nSize As Long, _
Arguments As Long) As Long
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0
Private Const ENDSESSION_LOGOFF = &H80000000
' errori API
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const SE_SHUTDOWN_NAME = "SeShutdownPrivilege"
Private Const SE_PRIVILEGE_ENABLED = &H2
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
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 = (STANDARD_RIGHTS_REQUIRED Or _
TOKEN_ASSIGN_PRIMARY Or _
TOKEN_DUPLICATE Or _
TOKEN_IMPERSONATE Or _
TOKEN_QUERY Or _
TOKEN_QUERY_SOURCE Or _
TOKEN_ADJUST_PRIVILEGES Or _
TOKEN_ADJUST_GROUPS Or _
TOKEN_ADJUST_DEFAULT)
Private Const TOKEN_READ = (STANDARD_RIGHTS_READ Or _
TOKEN_QUERY)
Private Const TOKEN_WRITE = (STANDARD_RIGHTS_WRITE Or _
TOKEN_ADJUST_PRIVILEGES Or _
TOKEN_ADJUST_GROUPS Or _
TOKEN_ADJUST_DEFAULT)
Private Const TOKEN_EXECUTE = (STANDARD_RIGHTS_EXECUTE)
Private Const TokenDefaultDacl = 6
Private Const TokenGroups = 2
Private Const TokenImpersonationLevel = 9
Private Const TokenOwner = 4
Private Const TokenPrimaryGroup = 5
Private Const TokenPrivileges = 3
Private Const TokenSource = 7
Private Const TokenStatistics = 10
Private Const TokenType = 8
Private Const TokenUser = 1
' ============================================================
Public Function WinError(ByVal lLastDLLError As Long) As String
Dim sBuff As String
Dim lCount As Long
sBuff = String$(256, 0)
lCount = FormatMessage( _
FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _
0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0)
If lCount Then
WinError = Left$(sBuff, lCount)
End If
End Function
Public Function IsNT() As Boolean
Static bOnce As Boolean
Static bValue As Boolean
If Not (bOnce) Then
Dim tVI As OSVERSIONINFO
tVI.dwOSVersionInfoSize = Len(tVI)
If (GetVersionEx(tVI) <> 0) Then
bValue = (tVI.dwPlatformId = VER_PLATFORM_WIN32_NT)
bOnce = True
End If
End If
IsNT = bValue
End Function
Private Function NTEnableShutDown(ByRef sMsg As String) As Boolean
Dim tLUID As LUID
Dim hProcess As Long
Dim hToken As Long
Dim tTP As TOKEN_PRIVILEGES, tTPOld As TOKEN_PRIVILEGES
Dim lTpOld As Long
Dim lR As Long
lR = LookupPrivilegeValue(vbNullString, SE_SHUTDOWN_NAME, tLUID)
If (lR <> 0) Then
hProcess = GetCurrentProcess()
If (hProcess <> 0) Then
lR = OpenProcessToken(hProcess, _
TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hToken)
If (lR <> 0) Then
With tTP
.PrivilegeCount = 1
With .Privileges(0)
.Attributes = SE_PRIVILEGE_ENABLED
.pLuid.HighPart = tLUID.HighPart
.pLuid.LowPart = tLUID.LowPart
End With
End With
lR = AdjustTokenPrivileges(hToken, 0, tTP, Len(tTP), tTPOld, lTpOld)
If (lR <> 0) Then
NTEnableShutDown = True
Else
Err.Raise eeSSDErrorBase + 6, App.EXEName & ".mShutDown", _
"impossibile spegnere mancano i privilegi: " & _
"[" & WinError(Err.LastDllError) & "]"
End If
CloseHandle hToken
Else
Err.Raise eeSSDErrorBase + 6, App.EXEName & ".mShutDown", _
"impossibile spegnere mancano i privilegi: " & _
"[" & WinError(Err.LastDllError) & "]"
End If
Else
Err.Raise eeSSDErrorBase + 5, App.EXEName & ".mShutDown", _
"impossibile spegnere processo sconosciuto: " & _
"[" & WinError(Err.LastDllError) & "]"
End If
Else
Err.Raise eeSSDErrorBase + 4, App.EXEName & ".mShutDown", _
"impossibile spegnere messaggio sconosciuto: " & _
"[" & WinError(Err.LastDllError) & "]"
End If
End Function
Public Function ShutdownSystem( _
Optional ByVal eType As EShutDownTypes = EWX_RESET _
) As Boolean
Dim lR As Long
Dim sMsg As String
If (eType < EShutDownTypes.[_First] And eType > EShutDownTypes.[_Last]) Then
Err.Raise eeSSDErrorBase + 7, App.EXEName & ".mShutDown", _
"Invalid parameter to ShutdownSystem: " & eType, vbInformation
Exit Function
End If
If (IsNT) Then
If Not (NTEnableShutDown(sMsg)) Then
Exit Function
End If
End If
lR = ExitWindowsEx(eType, &HFFFFFFFF)
If (lR = 0) Then
Err.Raise eeSSDErrorBase + 3, App.EXEName & ".mShutDown", _
"ShutdownSystem failed: " & WinError(Err.LastDllError)
Else
'ora lo spegnimento avverrà in un'altro processo indipendente
'ma il nostro processo continua
ShutdownSystem = True
End If
End Function
nella procedura che lo utilizza
Rispondi quotando