explix.bas

学校机房的上机管理系统.可以安排免费上机,可以收费上机.适合中小型机房.修改后也可以作为网吧管理软件.

Attribute VB_Name = "Module1"
Option Explicit
Public db As Connection             '数据库
Public rec_base As Recordset        '基本信息
Public rec_count As ADODB.Recordset '账户
Public rec_info As ADODB.Recordset  '其他信息，包括密码
Public rec_used As ADODB.Recordset  '使用记录
Public rec_class As ADODB.Recordset '班级信息
Public rec_sys_info As ADODB.Recordset '系统信息


'以下是监控过程所用API
Public Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Public Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Public Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Public Const MAX_PATH As Integer = 260
Public 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 Id As Long
Public Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Const TH32CS_SNAPPROCESS = &H2
Public Const TH32CS_SNAPheaplist = &H1
Public Const TH32CS_SNAPthread = &H4
Public Const TH32CS_SNAPmodule = &H8
Public Const TH32CS_SNAPall = TH32CS_SNAPPROCESS + TH32CS_SNAPheaplist + TH32CS_SNAPthread + TH32CS_SNAPmodule


'以下是禁用任务管理器API
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

'##############################################
'以下强制关机功能


Private Const EWX_POWEROFF = 8                          '关闭系统并关闭电源
Private Const EWX_SHUTDOWN = 1                          '关闭系统使之能安全关闭电源

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

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 ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved 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, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long

'以下制作系统托盘

Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Const WM_SYSCOMMAND = &H112
Public Const SC_RESTORE = &HF120&
Public LastState As Integer '保留原窗口状态

'---------- dwMessage可以是以下NIM_ADD、NIM_DELETE、NIM_MODIFY 标识符之一----------
Public Const NIM_ADD = &H0 '在任务栏中增加一个图标
Public Const NIM_DELETE = &H2 '删除任务栏中的一个图标
Public Const NIM_MODIFY = &H1 '修改任务栏中个图标信息

Public Const NIF_MESSAGE = &H1 'NOTIFYICONDATA结构中uFlags的控制信息
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4

Public Const WM_MOUSEMOVE = &H200 '当鼠标指针移至图标上

Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONUP = &H205
Public Type NOTIFYICONDATA
  cbSize As Long '该数据结构的大小
  hwnd As Long '处理任务栏中图标的窗口句柄
  uID As Long '定义的任务栏中图标的标识
  uFlags As Long '任务栏图标功能控制，可以是以下值的组合（一般全包括）
  'NIF_MESSAGE 表示发送控制消息；
  'NIF_ICON表示显示控制栏中的图标；
  'NIF_TIP表示任务栏中的图标有动态提示。
  uCallbackMessage As Long '任务栏图标通过它与用户程序交换消息，处理该消息的窗口由hWnd决定
  hIcon As Long '任务栏中的图标的控制句柄
  szTip As String * 64 '图标的提示信息
End Type





Public Function GetJingCheng(Exename As String) As String    ' \取得进程
GetJingCheng = ""


Dim theloop As Long
Dim proc As PROCESSENTRY32
Dim snap As Long
Dim Lent As Integer
Lent = Len(Exename)
GetJingCheng = ""    '清空所有内容
snap = CreateToolhelpSnapshot(TH32CS_SNAPall, 0)  '获得进程“快照”的句柄
proc.dwSize = Len(proc)
theloop = ProcessFirst(snap, proc)   '获取第一个进程，并得到其返回值
While theloop <> 0  '当返回值非零时继续获取下一个进程

 If Left(proc.szExeFile, Lent) = Exename Then
    GetJingCheng = proc.th32ProcessID
 End If


theloop = ProcessNext(snap, proc)
Wend
CloseHandle snap '关闭进程“快照”句柄
End Function


Public Function EndJingCheng(MyId As Long) As Long ' 结束进程
Dim i As Long
Dim Mystr As String
Dim hand As Long


hand = OpenProcess(1, True, MyId) '获取进程句柄
EndJingCheng = TerminateProcess(hand, 1) '关闭进程
End Function

Public Sub SaveStringWORD(hKey As Long, strPath As String, strValue As String, strData As String)
    Dim Ret
    'Create a new key
    RegCreateKey hKey, strPath, Ret
    'Set the key's value
    RegSetValueEx Ret, strValue, 0, 4, CLng(strData), 4
    'close the key
    RegCloseKey Ret
End Sub


'这个函数就是用于NT关机中使用的
Sub AdjustTokenPrivilegesForNT()
    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
    
    hdlProcessHandle = GetCurrentProcess()
    OpenProcessToken hdlProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or _
    TOKEN_QUERY), hdlTokenHandle
    
    LookupPrivilegeValue "", "SeShutdownPrivilege", tmpLuid
    tkp.PrivilegeCount = 1
    tkp.Privileges(0).pLuid = tmpLuid
    tkp.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
    
    AdjustTokenPrivileges hdlTokenHandle, False, tkp, _
    Len(tkpNewButIgnored), tkpNewButIgnored, _
    lBufferNeeded
End Sub

Public Function ShutDownPC()
    
    Call AdjustTokenPrivilegesForNT             '是NT以上系统就要先调用这个
    
    ExitWindowsEx EWX_POWEROFF Or EWX_SHUTDOWN Or EWX_FORCE, 0              '强制关机
End Function