Private Const EWX_LOGOFF = 0 Private Const EWX_SHUTDOWN = 1 Private Const EWX_REBOOT = 2 Private Const EWX_FORCE = 4 Private Const TOKEN_ADJUST_PRIVILEGES = &H20 Private Const TOKEN_QUERY = &H8 Private Const SE_PRIVILEGE_ENABLED = &H2 Private Const ANYSIZE_ARRAY = 1 Private Const VER_PLATFORM_WIN32_NT = 2 Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 End Type Type LUID LowPart As Long HighPart As Long End Type Type LUID_AND_ATTRIBUTES pLuid As LUID Attributes As Long End Type Type TOKEN_PRIVILEGES PrivilegeCount As Long Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES End Type 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 Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long 'Detect if the program is running under Windows NT Public Function IsWinNT() As Boolean Dim myOS As OSVERSIONINFO myOS.dwOSVersionInfoSize = Len(myOS) GetVersionEx myOS IsWinNT = (myOS.dwPlatformId = VER_PLATFORM_WIN32_NT) End Function 'set the shut down privilege for the current application Private Sub EnableShutDown() Dim hProc As Long Dim hToken As Long Dim mLUID As LUID Dim mPriv As TOKEN_PRIVILEGES Dim mNewPriv As TOKEN_PRIVILEGES hProc = GetCurrentProcess() OpenProcessToken hProc, TOKEN_ADJUST_PRIVILEGES + TOKEN_QUERY, hToken LookupPrivilegeValue "", "SeShutdownPrivilege", mLUID mPriv.PrivilegeCount = 1 mPriv.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED mPriv.Privileges(0).pLuid = mLUID ' enable shutdown privilege for the current application AdjustTokenPrivileges hToken, False, mPriv, 4 + (12 * mPriv.PrivilegeCount), mNewPriv, 4 + (12 * mNewPriv.PrivilegeCount) End Sub ' Shut Down NT Public Sub ShutDownNT(Force As Boolean) Dim ret As Long Dim Flags As Long Flags = EWX_SHUTDOWN If Force Then Flags = Flags + EWX_FORCE If IsWinNT Then EnableShutDown ExitWindowsEx Flags, 0 End Sub 'Restart NT Public Sub RebootNT(Force As Boolean) Dim ret As Long Dim Flags As Long Flags = EWX_REBOOT If Force Then Flags = Flags + EWX_FORCE If IsWinNT Then EnableShutDown ExitWindowsEx Flags, 0 End Sub 'Log off the current user Public Sub LogOffNT(Force As Boolean) Dim ret As Long Dim Flags As Long Flags = EWX_LOGOFF If Force Then Flags = Flags + EWX_FORCE ExitWindowsEx Flags, 0 End Sub'In a form 'This project needs a form with three command buttons Private Sub Command1_Click() LogOffNT True End Sub Private Sub Command2_Click() RebootNT True End Sub Private Sub Command3_Click() ShutDownNT True End Sub Private Sub Form_Load() Command1.Caption = "Log Off NT" Command2.Caption = "Reboot NT" Command3.Caption = "Shutdown NT" End Sub
上边是为win2000设计的，因为下面的代码在98可以2000失效 'In general section Const EWX_LOGOFF = 0 Const EWX_SHUTDOWN = 1 Const EWX_REBOOT = 2 Const EWX_FORCE = 4 Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long Private Sub Form_Load() msg = MsgBox("This program is going to reboot your computer. Press OK to continue or Cancel to stop.", vbCritical + vbOKCancel + 256, App.Title) If msg = vbCancel Then End 'reboot the computer ret& = ExitWindowsEx(EWX_FORCE Or EWX_REBOOT, 0) End Sub
Private Declare Function SetWindowPos& Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long Const SHUTDOWN = 1 Const REBOOT = 2 Const LOGOFF = 0 Dim sh As Long Dim counter As Integer Dim n As Long Dim m As String Private Sub Check1_Click() If Check1.Value = 1 Then Label3(0).Caption = "小时" End If End SubPrivate Sub Check2_Click() If Check2.Value = 1 Then Label3(0).Caption = "点" End If End SubPrivate Sub Combo1_click() Combo1.BackColor = &H800000 Combo1.ForeColor = &HFFFFFF Select Case Combo1.ListIndex Case 0 Label2.Caption = "结束会话，关闭Windows，以便安全关闭电源。" Case 1 Label2.Caption = "结束会话，关闭Windows，然后重新启动。" Case 2 Label2.Caption = "结束会话，用户重新登陆。" End Select End SubPrivate Sub Combo1_DropDown() Combo1.BackColor = &HFFFFFF Combo1.ForeColor = &H0 End SubPrivate Sub Command1_Click() Dim str As String If Command2.Enabled = True Then Select Case Combo1.ListIndex Case 0 shutdown1 Case 1 reboot1 Case 2 logoff1 End SelectElse If Check2.Value = 1 Then If Len(Text2.Text) = 1 Thenm = Trim(Text1.Text) + ":" + "0" + Trim(Text2.Text) Else m = Trim(Text1.Text) + ":" + Trim(Text2.Text) End IfIf Len(Text3.Text) = 1 Then m = m + ":" + "0" + Trim(Text3.Text) Else m = m + ":" + Trim(Text3.Text) End IfDebug.Print mEnd If If Check1.Value = 0 And Check2.Value = 0 And Check3.Value = 0 Then Select Case Combo1.ListIndex Case 0 shutdown1 Case 1 reboot1 Case 2 logoff1 End Select Else If Check1.Value = 0 And Check2.Value = 0 Then str = MsgBox("你还有设置漏选！", 48, "错误") End If End If n = Val(Text1.Text) * 3600 + Val(Text2.Text) * 60 + Val(Text3.Text) If Check2.Value = 1 Then If Text1.Text = "" Then Text1.Text = "0" End If If Text2.Text = "" Then Text2.Text = "0" End If If Text3.Text = "" Then Text3.Text = "0" End If End If If Check1.Value = 1 Then If Val(Text3.Text) > 60 Or Val(Text2.Text) > 60 Then MsgBox "填入的数据错误，要重填！", 48, "错误" n = 0 Exit Sub End If If Text1.Text <> "0" And Text2.Text = "0" Then Text2.Text = "60" End If If Text2.Text <> "0" And Text3.Text = "0" Then Text3.Text = "60" End If End If Timer1.Enabled = True End If End SubPrivate Sub Command2_Click() Dim str As String If Combo1.Text = "" Then str = MsgBox("请选择操作类型！", 0, "错误") Exit Sub End If Frame1.Visible = True Command2.Enabled = False End SubPrivate Sub Command3_Click() End End SubPrivate Sub Command4_Click() Call ShellAbout(hwnd, "关闭Windows", "本软件由 HydeKong 制作！" & vbCrLf & "谢谢使用！", Me.Icon) End SubPrivate Sub Command5_Click() If Timer1.Enabled = True Then Timer1.Enabled = False End If Text1.Text = 0 Text2.Text = 0 Text3.Text = 0 End SubPrivate Sub Form_Load() Frame1.Visible = False Label2.Caption = "" Combo1.AddItem "关机" Combo1.AddItem "重新启动" Combo1.AddItem "注销" counter = 0 Timer1.Enabled = False End SubPrivate Sub shutdown1() sh = ExitWindowsEx(SHUTDOWN, dwReserved) End SubPrivate Sub reboot1() sh = ExitWindowsEx(REBOOT, dwReserved) End SubPrivate Sub logoff1() sh = ExitWindowsEx(LOGOFF, dwReserved) End SubPrivate Sub Text1_KeyPress(KeyAscii As Integer) Key = Chr(KeyAscii) If KeyAscii <> 8 And Key < "0" Or Key > "9" Then MsgBox "请填入数字！" End If End SubPrivate Sub Text2_KeyPress(KeyAscii As Integer) Key = Chr(KeyAscii) If KeyAscii <> 8 And Key < "0" Or Key > "9" Then MsgBox "请填入数字！" End If End SubPrivate Sub Text3_KeyPress(KeyAscii As Integer) Key = Chr(KeyAscii) If KeyAscii <> 8 And Key < "0" Or Key > "9" Then MsgBox "请填入数字！" End If End SubPrivate Sub Timer1_Timer() counter = counter + 1If Check1.Value = 1 Then If Text1.Text <> 0 And Text2.Text = "60" Then Text1.Text = Text1.Text - "1" End If If Text2.Text <> 0 And Text3.Text = "60" Then Text2.Text = Text2.Text - "1" End If If Text3.Text <> 0 Then Text3.Text = Text3.Text - "1" End If If Text2.Text = "0" And Text1.Text <> "0" Then Text2.Text = "60" End If If Text3.Text = "0" And Text2.Text <> "0" Then Text3.Text = "60" End If End If Dim ch As String If Check3.Value = 1 Then If n > 300 Then If n - counter = 300 Then Dim rtn rtn = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3) ch = MsgBox("还有5分钟就要关机，是否继续执行？", 48 + vbYesNo, "提醒") If ch = vbNo Then Timer1.Enabled = False rtn = SetWindowPos(Me.hwnd, -2, 0, 0, 0, 0, 3) counter = 0 Exit Sub Else MsgBox "请做好数据保存，就要关机了！", 48, "提醒" End If End If End If End If If (n - counter) = 0 Then Select Case Combo1.ListIndex Case 0 shutdown1 Case 1 reboot1 Case 2 logoff1 End Select End If End SubPrivate Sub Timer2_Timer() If Check2.Value = 1 Then If m = Time() Then Select Case Combo1.ListIndex Case 0 shutdown1 Case 1 reboot1 Case 2 logoff1 End Select End If End IfEnd Sub
转贴（晓琴）关机函数模块 Option ExplicitDeclare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As LongPrivate Const EWX_POWEROFF As Long = 8& Private Const EWX_FORCE As Long = 4& Private Const EWX_REBOOT As Long = 2& Private Const EWX_LOGOFF As Long = 0& Private Const EWX_SHUTDOWN As Long = 1&Private Const ERROR_SUCCESS As Long = 0& Private Const ERROR_NOT_ALL_ASSIGNED As Long = 1300&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 Any, ByVal lpName As String, lpLuid As LUID) 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 LongPrivate Const TOKEN_QUERY As Long = &H8& Private Const TOKEN_ADJUST_PRIVILEGES As Long = &H20& Private Const SE_PRIVILEGE_ENABLED As Long = &H2Private Type LUID lowpart As Long highpart As Long End TypePrivate Type LUID_AND_ATTRIBUTES pLuid As LUID Attributes As Long End TypePrivate Type TOKEN_PRIVILEGES PrivilegeCount As Long Privileges As LUID_AND_ATTRIBUTES End TypePublic Sub LogOff() Dim p_lngRtn As Long Dim p_lngFlags As Long
p_lngFlags = EWX_LOGOFF p_lngRtn = ExitWindowsEx(p_lngFlags, 0&)End SubPublic Sub Reboot(ByVal xi_blnForce As Boolean) Dim p_lngRtn As Long Dim p_lngFlags As Long Dim p_lngToken As Long Dim p_lngBufLen As Long Dim p_lngLastErr As Long Dim p_typLUID As LUID Dim p_typTokenPriv As TOKEN_PRIVILEGES Dim p_typPrevTokenPriv As TOKEN_PRIVILEGES
p_lngRtn = OpenProcessToken(GetCurrentProcess(), _ TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, _ p_lngToken) If p_lngRtn = 0 Then ' Failed Debug.Print ReturnApiErrString(Err.LastDllError) Exit Sub End If
p_lngRtn = LookupPrivilegeValue(0&, "SeShutdownPrivilege", p_typLUID) If p_lngRtn = 0 Then ' Failed Debug.Print ReturnApiErrString(Err.LastDllError) Exit Sub End If
p_lngRtn = AdjustTokenPrivileges(p_lngToken, False, _ p_typTokenPriv, Len(p_typPrevTokenPriv), _ p_typPrevTokenPriv, p_lngBufLen) If p_lngRtn = 0 Then ' Failed Debug.Print Err.LastDllError, ReturnApiErrString(Err.LastDllError) Exit Sub Else p_lngLastErr = Err.LastDllError If p_lngLastErr = ERROR_SUCCESS Then ' Everything is OK ElseIf p_lngLastErr = ERROR_NOT_ALL_ASSIGNED Then Debug.Print "Not all privileges assigned." Else Debug.Print p_lngLastErr, ReturnApiErrString(p_lngLastErr) End If End If
If xi_blnForce = False Then p_lngFlags = EWX_REBOOT Else p_lngFlags = EWX_REBOOT Or EWX_FORCE End If
p_lngRtn = ExitWindowsEx(p_lngFlags, 0&)
End SubPublic Sub Shutdown(ByVal xi_blnForce As Boolean) Dim p_lngRtn As Long Dim p_lngFlags As Long Dim p_lngToken As Long Dim p_lngBufLen As Long Dim p_lngLastErr As Long Dim p_typLUID As LUID Dim p_typTokenPriv As TOKEN_PRIVILEGES Dim p_typPrevTokenPriv As TOKEN_PRIVILEGES
p_lngRtn = OpenProcessToken(GetCurrentProcess(), _ TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, _ p_lngToken) If p_lngRtn = 0 Then ' Failed Debug.Print ReturnApiErrString(Err.LastDllError) Exit Sub End If
p_lngRtn = LookupPrivilegeValue(0&, "SeShutdownPrivilege", p_typLUID) If p_lngRtn = 0 Then ' Failed Debug.Print ReturnApiErrString(Err.LastDllError) Exit Sub End If
p_lngRtn = AdjustTokenPrivileges(p_lngToken, False, _ p_typTokenPriv, Len(p_typPrevTokenPriv), _ p_typPrevTokenPriv, p_lngBufLen) If p_lngRtn = 0 Then ' Failed Debug.Print Err.LastDllError, ReturnApiErrString(Err.LastDllError) Exit Sub Else p_lngLastErr = Err.LastDllError If p_lngLastErr = ERROR_SUCCESS Then ' Everything is OK ElseIf p_lngLastErr = ERROR_NOT_ALL_ASSIGNED Then Debug.Print "Not all privileges assigned." Else Debug.Print p_lngLastErr, ReturnApiErrString(p_lngLastErr) End If End If
If xi_blnForce = False Then p_lngFlags = EWX_SHUTDOWN Or EWX_POWEROFF Else p_lngFlags = EWX_SHUTDOWN Or EWX_POWEROFF Or EWX_FORCE End If
p_lngRtn = ExitWindowsEx(p_lngFlags, 0&) End Sub
转贴（晓琴） 错误处理模块 ' ********************************************* ' API_ERR.BAS -- Copyright (c) Slightly Tilted Software ' By: L.J. Johnson Date: 12-01-1996 ' Comments: Contains only ReturnApiErrString() ' ********************************************* Option Explicit DefInt A-Z' --------------------------------------------- ' Used for Event logging ' --------------------------------------------- Private Const mconstModName = "A_Service2.modAPI_Error"' ------------------------------------------------- ' Used to get error messages directly from the ' system instead of hard-coding them ' ------------------------------------------------- Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000 Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200Private 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' -------------------------------------------------------- ' Status Codes ' -------------------------------------------------------- Public Const INVALID_HANDLE_VALUE = -1& Public Const ERROR_SUCCESS = 0&' ------------------------------------------------- ' API_ERR.BAS / ReturnApiErrString ' ' Passed an API error number, return an error ' string ' ' Comments: Takes an API error number, and returns ' a descriptive text string of the error ' Inputs: xlngError is the number returned from ' the API error ' Outputs: Function returns the error string ' ' The original code appeared in Keith Pleas' article ' in VBPJ, April 1996 (OLE Expert column). Thanks, ' Keith. ' ------------------------------------------------- Public Function ReturnApiErrString(ErrorCode As Long) As String On Error Resume Next Dim strBuffer As String ' ---------------------------------------------- ' Allocate the string, then get the system to ' tell us the error message associated with ' this error number ' ---------------------------------------------- strBuffer = String$(256, 0) FormatMessage FORMAT_MESSAGE_FROM_SYSTEM _ Or FORMAT_MESSAGE_IGNORE_INSERTS, 0&, _ ErrorCode, 0&, strBuffer, Len(strBuffer), 0& ' ---------------------------------------------- ' Strip the last null, then the last CrLf pair if ' it exists ' ---------------------------------------------- strBuffer = Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1) If Right$(strBuffer, 2) = vbCrLf Then strBuffer = Mid$(strBuffer, 1, Len(strBuffer) - 2) End If ' ---------------------------------------------- ' Set the return value ' ---------------------------------------------- ReturnApiErrString = strBufferOn Error GoTo 0 End Function ------------ 重启Reboot False 关机Shutdown False 强制重启Reboot True 强制关机Shutdown True 强制不提示保存
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4
Private Const TOKEN_ADJUST_PRIVILEGES = &H20
Private Const TOKEN_QUERY = &H8
Private Const SE_PRIVILEGE_ENABLED = &H2
Private Const ANYSIZE_ARRAY = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Type LUID
LowPart As Long
HighPart As Long
End Type
Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
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 Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long,
ByVal dwReserved As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA"
(ByRef lpVersionInformation As OSVERSIONINFO) As Long
'Detect if the program is running under Windows NT
Public Function IsWinNT() As Boolean
Dim myOS As OSVERSIONINFO
myOS.dwOSVersionInfoSize = Len(myOS)
GetVersionEx myOS
IsWinNT = (myOS.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Function
'set the shut down privilege for the current application
Private Sub EnableShutDown()
Dim hProc As Long
Dim hToken As Long
Dim mLUID As LUID
Dim mPriv As TOKEN_PRIVILEGES
Dim mNewPriv As TOKEN_PRIVILEGES
hProc = GetCurrentProcess()
OpenProcessToken hProc, TOKEN_ADJUST_PRIVILEGES + TOKEN_QUERY, hToken
LookupPrivilegeValue "", "SeShutdownPrivilege", mLUID
mPriv.PrivilegeCount = 1
mPriv.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
mPriv.Privileges(0).pLuid = mLUID
' enable shutdown privilege for the current application
AdjustTokenPrivileges hToken, False, mPriv, 4 + (12 *
mPriv.PrivilegeCount), mNewPriv, 4 + (12 * mNewPriv.PrivilegeCount)
End Sub
' Shut Down NT
Public Sub ShutDownNT(Force As Boolean)
Dim ret As Long
Dim Flags As Long
Flags = EWX_SHUTDOWN
If Force Then Flags = Flags + EWX_FORCE
If IsWinNT Then EnableShutDown
ExitWindowsEx Flags, 0
End Sub
'Restart NT
Public Sub RebootNT(Force As Boolean)
Dim ret As Long
Dim Flags As Long
Flags = EWX_REBOOT
If Force Then Flags = Flags + EWX_FORCE
If IsWinNT Then EnableShutDown
ExitWindowsEx Flags, 0
End Sub
'Log off the current user
Public Sub LogOffNT(Force As Boolean)
Dim ret As Long
Dim Flags As Long
Flags = EWX_LOGOFF
If Force Then Flags = Flags + EWX_FORCE
ExitWindowsEx Flags, 0
End Sub'In a form
'This project needs a form with three command buttons
Private Sub Command1_Click()
LogOffNT True
End Sub
Private Sub Command2_Click()
RebootNT True
End Sub
Private Sub Command3_Click()
ShutDownNT True
End Sub
Private Sub Form_Load() Command1.Caption = "Log Off NT"
Command2.Caption = "Reboot NT"
Command3.Caption = "Shutdown NT"
End Sub
'In general section
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Sub Form_Load() msg = MsgBox("This program is going to reboot your computer. Press OK to continue or Cancel to stop.", vbCritical + vbOKCancel + 256, App.Title)
If msg = vbCancel Then End
'reboot the computer
ret& = ExitWindowsEx(EWX_FORCE Or EWX_REBOOT, 0)
End Sub
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Const SHUTDOWN = 1
Const REBOOT = 2
Const LOGOFF = 0
Dim sh As Long
Dim counter As Integer
Dim n As Long
Dim m As String
Private Sub Check1_Click()
If Check1.Value = 1 Then
Label3(0).Caption = "小时"
End If
End SubPrivate Sub Check2_Click()
If Check2.Value = 1 Then
Label3(0).Caption = "点"
End If
End SubPrivate Sub Combo1_click()
Combo1.BackColor = &H800000
Combo1.ForeColor = &HFFFFFF
Select Case Combo1.ListIndex
Case 0
Label2.Caption = "结束会话，关闭Windows，以便安全关闭电源。"
Case 1
Label2.Caption = "结束会话，关闭Windows，然后重新启动。"
Case 2
Label2.Caption = "结束会话，用户重新登陆。"
End Select
End SubPrivate Sub Combo1_DropDown()
Combo1.BackColor = &HFFFFFF
Combo1.ForeColor = &H0
End SubPrivate Sub Command1_Click()
Dim str As String
If Command2.Enabled = True Then
Select Case Combo1.ListIndex
Case 0
shutdown1
Case 1
reboot1
Case 2
logoff1
End SelectElse
If Check2.Value = 1 Then
If Len(Text2.Text) = 1 Thenm = Trim(Text1.Text) + ":" + "0" + Trim(Text2.Text)
Else
m = Trim(Text1.Text) + ":" + Trim(Text2.Text)
End IfIf Len(Text3.Text) = 1 Then
m = m + ":" + "0" + Trim(Text3.Text)
Else
m = m + ":" + Trim(Text3.Text)
End IfDebug.Print mEnd If
If Check1.Value = 0 And Check2.Value = 0 And Check3.Value = 0 Then
Select Case Combo1.ListIndex
Case 0
shutdown1
Case 1
reboot1
Case 2
logoff1
End Select
Else
If Check1.Value = 0 And Check2.Value = 0 Then
str = MsgBox("你还有设置漏选！", 48, "错误")
End If
End If
n = Val(Text1.Text) * 3600 + Val(Text2.Text) * 60 + Val(Text3.Text)
If Check2.Value = 1 Then
If Text1.Text = "" Then
Text1.Text = "0"
End If
If Text2.Text = "" Then
Text2.Text = "0"
End If
If Text3.Text = "" Then
Text3.Text = "0"
End If
End If
If Check1.Value = 1 Then
If Val(Text3.Text) > 60 Or Val(Text2.Text) > 60 Then
MsgBox "填入的数据错误，要重填！", 48, "错误"
n = 0
Exit Sub
End If
If Text1.Text <> "0" And Text2.Text = "0" Then
Text2.Text = "60"
End If
If Text2.Text <> "0" And Text3.Text = "0" Then
Text3.Text = "60"
End If
End If
Timer1.Enabled = True
End If
End SubPrivate Sub Command2_Click()
Dim str As String
If Combo1.Text = "" Then
str = MsgBox("请选择操作类型！", 0, "错误")
Exit Sub
End If
Frame1.Visible = True
Command2.Enabled = False
End SubPrivate Sub Command3_Click()
End
End SubPrivate Sub Command4_Click()
Call ShellAbout(hwnd, "关闭Windows", "本软件由 HydeKong 制作！" & vbCrLf & "谢谢使用！", Me.Icon)
End SubPrivate Sub Command5_Click()
If Timer1.Enabled = True Then
Timer1.Enabled = False
End If
Text1.Text = 0
Text2.Text = 0
Text3.Text = 0
End SubPrivate Sub Form_Load()
Frame1.Visible = False
Label2.Caption = ""
Combo1.AddItem "关机"
Combo1.AddItem "重新启动"
Combo1.AddItem "注销"
counter = 0
Timer1.Enabled = False
End SubPrivate Sub shutdown1()
sh = ExitWindowsEx(SHUTDOWN, dwReserved)
End SubPrivate Sub reboot1()
sh = ExitWindowsEx(REBOOT, dwReserved)
End SubPrivate Sub logoff1()
sh = ExitWindowsEx(LOGOFF, dwReserved)
End SubPrivate Sub Text1_KeyPress(KeyAscii As Integer)
Key = Chr(KeyAscii)
If KeyAscii <> 8 And Key < "0" Or Key > "9" Then
MsgBox "请填入数字！"
End If
End SubPrivate Sub Text2_KeyPress(KeyAscii As Integer)
Key = Chr(KeyAscii)
If KeyAscii <> 8 And Key < "0" Or Key > "9" Then
MsgBox "请填入数字！"
End If
End SubPrivate Sub Text3_KeyPress(KeyAscii As Integer)
Key = Chr(KeyAscii)
If KeyAscii <> 8 And Key < "0" Or Key > "9" Then
MsgBox "请填入数字！"
End If
End SubPrivate Sub Timer1_Timer()
counter = counter + 1If Check1.Value = 1 Then
If Text1.Text <> 0 And Text2.Text = "60" Then
Text1.Text = Text1.Text - "1"
End If
If Text2.Text <> 0 And Text3.Text = "60" Then
Text2.Text = Text2.Text - "1"
End If
If Text3.Text <> 0 Then
Text3.Text = Text3.Text - "1"
End If
If Text2.Text = "0" And Text1.Text <> "0" Then
Text2.Text = "60"
End If
If Text3.Text = "0" And Text2.Text <> "0" Then
Text3.Text = "60"
End If
End If
Dim ch As String
If Check3.Value = 1 Then
If n > 300 Then
If n - counter = 300 Then
Dim rtn
rtn = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)
ch = MsgBox("还有5分钟就要关机，是否继续执行？", 48 + vbYesNo, "提醒")
If ch = vbNo Then
Timer1.Enabled = False
rtn = SetWindowPos(Me.hwnd, -2, 0, 0, 0, 0, 3)
counter = 0
Exit Sub
Else
MsgBox "请做好数据保存，就要关机了！", 48, "提醒"
End If
End If
End If
End If
If (n - counter) = 0 Then
Select Case Combo1.ListIndex
Case 0
shutdown1
Case 1
reboot1
Case 2
logoff1
End Select
End If
End SubPrivate Sub Timer2_Timer()
If Check2.Value = 1 Then
If m = Time() Then
Select Case Combo1.ListIndex
Case 0
shutdown1
Case 1
reboot1
Case 2
logoff1
End Select
End If
End IfEnd Sub
Option ExplicitDeclare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As LongPrivate Const EWX_POWEROFF As Long = 8&
Private Const EWX_FORCE As Long = 4&
Private Const EWX_REBOOT As Long = 2&
Private Const EWX_LOGOFF As Long = 0&
Private Const EWX_SHUTDOWN As Long = 1&Private Const ERROR_SUCCESS As Long = 0&
Private Const ERROR_NOT_ALL_ASSIGNED As Long = 1300&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 Any, ByVal lpName As String, lpLuid As LUID) 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 LongPrivate Const TOKEN_QUERY As Long = &H8&
Private Const TOKEN_ADJUST_PRIVILEGES As Long = &H20&
Private Const SE_PRIVILEGE_ENABLED As Long = &H2Private Type LUID
lowpart As Long
highpart As Long
End TypePrivate Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End TypePrivate Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges As LUID_AND_ATTRIBUTES
End TypePublic Sub LogOff()
Dim p_lngRtn As Long
Dim p_lngFlags As Long
p_lngFlags = EWX_LOGOFF
p_lngRtn = ExitWindowsEx(p_lngFlags, 0&)End SubPublic Sub Reboot(ByVal xi_blnForce As Boolean)
Dim p_lngRtn As Long
Dim p_lngFlags As Long
Dim p_lngToken As Long
Dim p_lngBufLen As Long
Dim p_lngLastErr As Long
Dim p_typLUID As LUID
Dim p_typTokenPriv As TOKEN_PRIVILEGES
Dim p_typPrevTokenPriv As TOKEN_PRIVILEGES
p_lngRtn = OpenProcessToken(GetCurrentProcess(), _
TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, _
p_lngToken)
If p_lngRtn = 0 Then
' Failed
Debug.Print ReturnApiErrString(Err.LastDllError)
Exit Sub
End If
p_lngRtn = LookupPrivilegeValue(0&, "SeShutdownPrivilege", p_typLUID)
If p_lngRtn = 0 Then
' Failed
Debug.Print ReturnApiErrString(Err.LastDllError)
Exit Sub
End If
p_typTokenPriv.PrivilegeCount = 1
p_typTokenPriv.Privileges.Attributes = SE_PRIVILEGE_ENABLED
p_typTokenPriv.Privileges.pLuid = p_typLUID
p_lngRtn = AdjustTokenPrivileges(p_lngToken, False, _
p_typTokenPriv, Len(p_typPrevTokenPriv), _
p_typPrevTokenPriv, p_lngBufLen)
If p_lngRtn = 0 Then
' Failed
Debug.Print Err.LastDllError, ReturnApiErrString(Err.LastDllError)
Exit Sub
Else
p_lngLastErr = Err.LastDllError
If p_lngLastErr = ERROR_SUCCESS Then
' Everything is OK
ElseIf p_lngLastErr = ERROR_NOT_ALL_ASSIGNED Then
Debug.Print "Not all privileges assigned."
Else
Debug.Print p_lngLastErr, ReturnApiErrString(p_lngLastErr)
End If
End If
If xi_blnForce = False Then
p_lngFlags = EWX_REBOOT
Else
p_lngFlags = EWX_REBOOT Or EWX_FORCE
End If
p_lngRtn = ExitWindowsEx(p_lngFlags, 0&)
End SubPublic Sub Shutdown(ByVal xi_blnForce As Boolean)
Dim p_lngRtn As Long
Dim p_lngFlags As Long
Dim p_lngToken As Long
Dim p_lngBufLen As Long
Dim p_lngLastErr As Long
Dim p_typLUID As LUID
Dim p_typTokenPriv As TOKEN_PRIVILEGES
Dim p_typPrevTokenPriv As TOKEN_PRIVILEGES
p_lngRtn = OpenProcessToken(GetCurrentProcess(), _
TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, _
p_lngToken)
If p_lngRtn = 0 Then
' Failed
Debug.Print ReturnApiErrString(Err.LastDllError)
Exit Sub
End If
p_lngRtn = LookupPrivilegeValue(0&, "SeShutdownPrivilege", p_typLUID)
If p_lngRtn = 0 Then
' Failed
Debug.Print ReturnApiErrString(Err.LastDllError)
Exit Sub
End If
p_typTokenPriv.PrivilegeCount = 1
p_typTokenPriv.Privileges.Attributes = SE_PRIVILEGE_ENABLED
p_typTokenPriv.Privileges.pLuid = p_typLUID
p_lngRtn = AdjustTokenPrivileges(p_lngToken, False, _
p_typTokenPriv, Len(p_typPrevTokenPriv), _
p_typPrevTokenPriv, p_lngBufLen)
If p_lngRtn = 0 Then
' Failed
Debug.Print Err.LastDllError, ReturnApiErrString(Err.LastDllError)
Exit Sub
Else
p_lngLastErr = Err.LastDllError
If p_lngLastErr = ERROR_SUCCESS Then
' Everything is OK
ElseIf p_lngLastErr = ERROR_NOT_ALL_ASSIGNED Then
Debug.Print "Not all privileges assigned."
Else
Debug.Print p_lngLastErr, ReturnApiErrString(p_lngLastErr)
End If
End If
If xi_blnForce = False Then
p_lngFlags = EWX_SHUTDOWN Or EWX_POWEROFF
Else
p_lngFlags = EWX_SHUTDOWN Or EWX_POWEROFF Or EWX_FORCE
End If
p_lngRtn = ExitWindowsEx(p_lngFlags, 0&)
End Sub
错误处理模块
' *********************************************
' API_ERR.BAS -- Copyright (c) Slightly Tilted Software
' By: L.J. Johnson Date: 12-01-1996
' Comments: Contains only ReturnApiErrString()
' *********************************************
Option Explicit
DefInt A-Z' ---------------------------------------------
' Used for Event logging
' ---------------------------------------------
Private Const mconstModName = "A_Service2.modAPI_Error"' -------------------------------------------------
' Used to get error messages directly from the
' system instead of hard-coding them
' -------------------------------------------------
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200Private 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' --------------------------------------------------------
' Status Codes
' --------------------------------------------------------
Public Const INVALID_HANDLE_VALUE = -1&
Public Const ERROR_SUCCESS = 0&' -------------------------------------------------
' API_ERR.BAS / ReturnApiErrString
'
' Passed an API error number, return an error
' string
'
' Comments: Takes an API error number, and returns
' a descriptive text string of the error
' Inputs: xlngError is the number returned from
' the API error
' Outputs: Function returns the error string
'
' The original code appeared in Keith Pleas' article
' in VBPJ, April 1996 (OLE Expert column). Thanks,
' Keith.
' -------------------------------------------------
Public Function ReturnApiErrString(ErrorCode As Long) As String
On Error Resume Next
Dim strBuffer As String ' ----------------------------------------------
' Allocate the string, then get the system to
' tell us the error message associated with
' this error number
' ----------------------------------------------
strBuffer = String$(256, 0)
FormatMessage FORMAT_MESSAGE_FROM_SYSTEM _
Or FORMAT_MESSAGE_IGNORE_INSERTS, 0&, _
ErrorCode, 0&, strBuffer, Len(strBuffer), 0&
' ----------------------------------------------
' Strip the last null, then the last CrLf pair if
' it exists
' ----------------------------------------------
strBuffer = Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1)
If Right$(strBuffer, 2) = vbCrLf Then
strBuffer = Mid$(strBuffer, 1, Len(strBuffer) - 2)
End If
' ----------------------------------------------
' Set the return value
' ----------------------------------------------
ReturnApiErrString = strBufferOn Error GoTo 0
End Function
------------
重启Reboot False
关机Shutdown False
强制重启Reboot True
强制关机Shutdown True
强制不提示保存