'这个是关机控制模块
Option Explicit
Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long
Private Declare Function GetLastError 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 TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
Private Declare Function GetVersion Lib "kernel32" () As Long
Public glngWhichWindows32 As Long
'以下是调用ShutDownWin时Mode的值：
Public Const EWX_LogOff As Long = 0 '注销
Public Const EWX_SHUTDOWN As Long = 1 '关机
Public Const EWX_REBOOT As Long = 2 '重启
Public Const EWX_FORCE As Long = 4 '强行关闭正在运行的任务；可以用 EWX_Force OR EWX_SHUTDOWN 即强行关闭所有运行中的程序关闭计算机电源。
Private Type LUID
UsedPart As Long
IgnoredForNowHigh32BitPart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
TheLuid As LUID
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
TheLuid As LUID
Attributes As Long
End Type
Public Sub ShutDownWin(ByVal Mode As Integer)
'********************************************************************
'* 这个过程允许程序在Windows下关机或者重新启动、注销当前用户。
'* 注：在Win2K、WinXP+VB6下测试通过，Win98下待测试。
'* Joforn*Ron
'* Email:Joforn@sohu.com
'* QQ:42978116
'********************************************************************
Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_QUERY = &H8
Const SE_PRIVILEGE_ENABLED = &H2
Dim hdlProcessHandle As Long
Dim hdlTokenHandle As Long
Dim tmpLuid As LUID
Dim tkp As TOKEN_PRIVILEGES
Dim tkpNewButIgnored As TOKEN_PRIVILEGES
Dim lBufferNeeded As Long
Dim lngVersion As Long
lngVersion = GetVersion()
If ((lngVersion And &H80000000) = 0) Then
'使用SetLastError函数设置错误代码为0。
'这样做，GetLastError函数如果没有错误会返回0
SetLastError 0
' GetCurrentProcess函数设置 hdlProcessHandle变量
hdlProcessHandle = GetCurrentProcess()
If GetLastError <> 0 Then
MsgBox "GetCurrentProcess error==" & GetLastError
End If
OpenProcessToken hdlProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY), hdlTokenHandle
If GetLastError <> 0 Then
MsgBox "OpenProcessToken error==" & GetLastError
End If
' 获得关机优先权的LUID
LookupPrivilegeValue "", "SeShutdownPrivilege", tmpLuid
If GetLastError <> 0 Then
MsgBox "LookupPrivilegeValue error==" & GetLastError
End If
tkp.PrivilegeCount = 1 ' 设置一个优先权
tkp.TheLuid = tmpLuid
tkp.Attributes = SE_PRIVILEGE_ENABLED
' 对当前进程使能关机优先权
AdjustTokenPrivileges hdlTokenHandle, False, tkp, Len(tkpNewButIgnored), tkpNewButIgnored, lBufferNeeded
If GetLastError <> 0 Then
MsgBox "AdjustTokenPrivileges error==" & GetLastError
End If
End If
ExitWindowsEx (Mode), &HFFFF
End Sub
'这段代码我在一个定时关机的程序中使用了一年多，经测试暂时还没有发现有问题，但其中有几个函数在Win98中没有，所以可能用Win98系统的可能会出问题。
[此贴子已经被作者于2007-2-22 12:08:06编辑过]
