systemapi.bas

此文档为VB公共模块

Attribute VB_Name = "SystemApi"
Option Explicit
'**************************系统相关**************************
'*作者：谢建军                                              *
'*创建日期：2002年11月18日  20：47                          *
'************************************************************
'*  1.GetWinPath                                            *
'*  2.Cwind(CloseMethod As ClsWinMthd)                      *
'*  3.SleepingFor(ByVal TimeVal As Integer)                 *
'*  4.ShowOrHideCursor(ByVal SorH As ShowOrHide)            *
'*  5.DisableCtrlAltDel(TorF As Boolean)                    *
'*  6.HideMe(TorF As Boolean)                               *
'*  7.ChgMosBut                                             *
'*  8.HideProcess(ToF As Boolean)                           *
'*  9.ChangDispTo(Byval X as integer,Byval Y as integer)    *
'*  10.GetDispXY(Byref X as integer,Byref Y as integer)     *
'*  11.GetKeyStateX(Byval cKeyCode as KeyCodeE)             *
'*  12.SetKeyState(ByVal cKeyCode As KeyCodeE, cOn As Boolean)
'*  13.Open any program or file with the relation program   *
'*  14.Get system current processes                         *
'************************************************************
Private Const TH32CS_SNAPHEAPLIST = &H1
Private Const TH32CS_SNAPPROCESS = &H2
Private Const TH32CS_SNAPTHREAD = &H4
Private Const TH32CS_SNAPMODULE = &H8
Private Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Private Const TH32CS_INHERIT = &H80000000
Private Const MAX_PATH As Integer = 260
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000
Private Type PROCESSENTRY32
    dwSize As Long '此结构大小
    cntUsage As Long '进程的引用数，如果为0，则次进程已停止
    th32ProcessID As Long '进程号
    th32DefaultHeapID As Long
    th32ModuleID As Long '此进程引用的模块ID
    cntThreads As Long '此进程创建的线程数
    th32ParentProcessID As Long '父进程的ID
    pcPriClassBase As Long '这个进程创建的线程的基本优先权
    dwFlags As Long '保留
    szExeFile As String * MAX_PATH
End Type
Private Type DEVMODE
        dmDeviceName As String * CCHDEVICENAME
        dmSpecVersion As Integer
        dmDriverVersion As Integer
        dmSize As Integer
        dmDriverExtra As Integer
        dmFields As Long
        dmOrientation As Integer
        dmPaperSize As Integer
        dmPaperLength As Integer
        dmPaperWidth As Integer
        dmScale As Integer
        dmCopies As Integer
        dmDefaultSource As Integer
        dmPrintQuality As Integer
        dmColor As Integer
        dmDuplex As Integer
        dmYResolution As Integer
        dmTTOption As Integer
        dmCollate As Integer
        dmFormName As String * CCHFORMNAME
        dmUnusedPadding As Integer
        dmBitsPerPel As Long
        dmPelsWidth As Long
        dmPelsHeight As Long
        dmDisplayFlags As Long
        dmDisplayFrequency As Long
End Type
'Exit windows
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
'Get windows directory
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'Sleep For A few Seconds
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Hide or show Cursor
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
'Get system information
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function SystemParametersInfoByVal Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long)
'System
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
'Change Mouse Button
Private Declare Function SwapMouseButton Lib "user32" (ByVal bSwap As Long) As Long
'about getdispxy
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'about changedisp
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (ByRef lpDevMode As DEVMODE, ByVal dwFlags As Long) As Long
'About GetKeyStateX
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
'About SetKeyState
Private Declare Function SetKeyboardState Lib "user32" (lppbKeyState As Byte) As Long
Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
'About Run
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'About GetProcess
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)

Private Const SPI_SETSCREENSAVEACTIVE As Long = 97&
Public Enum ClsWinMthd
  LogOff
  Reboot
  PowerOff
  LogOffForce
  RebootForce
  PowerOffForce
End Enum
Public Enum ShowOrHide
  Hide
  Show
End Enum
Public Enum KeyCodeE
  CapsLock = 20#
  NumLock = 144#
  ScrollLock = 145#
End Enum

Public Enum RunMode
    Auto = 0
    rOpen = 1
    rPrint = 2
    rExplore = 3
End Enum
Public Enum RunShowMode
    SW_HIDE = -1 '本来该=0
    SW_SHOWNORMAL = 1
    SW_SHOWMINIMIZED = 2
    SW_SHOWMAXIMIZED = 3
    SW_SHOWNOACTIVATE = 4
    SW_SHOW = 5
    SW_MINIMIZE = 6
    SW_SHOWMINNOACTIVE = 7
    SW_SHOWNA = 8
    SW_RESTORE = 9
End Enum

    
'************
'Exit Windows 98/95/Me
'************
Public Function Cwind(CloseMethod As ClsWinMthd) As Boolean
  Dim tCWin As Long
  Select Case CloseMethod
    Case LogOff
      tCWin = 0&
    Case Reboot
      tCWin = 2&
    Case PowerOff
      tCWin = 1&
    Case LogOffForce
      tCWin = 4&
    Case RebootForce
      tCWin = 2& Or 4&
    Case PowerOffForce
      tCWin = 1& Or 4&
    Case Else
      tCWin = 1&
  End Select
  If ExitWindowsEx(tCWin, 0) = 0 Then
    Cwind = False
  Else
    Cwind = True
  End If
End Function

'**********
'Get Windows Path
'**********
Public Function GetWinPath() As String
  
  Dim WinPathLength As Long, WinPath As String
  WinPathLength = 100
  WinPath = Space(WinPathLength)
  GetWindowsDirectory WinPath, WinPathLength
  WinPath = Left(Trim$(WinPath), Len(Trim$(WinPath)) - 1)
  GetWinPath = WinPath
End Function

'***********************
'Sleep For A few Seconds
'***********************
Public Function SleepingFor(ByVal TimeVal As Single) As Boolean
If TimeVal >= 0 Then
  Sleep CLng(TimeVal * 1000)
  SleepingFor = True
Else
  SleepingFor = False
End If
End Function

'***********************
'Show or hide cursor
'***********************
'windows维持着一个内部显示计数；倘若bShow为TRUE，
'那么每调用一次这个函数，计数就会递增1；反之，
'如bShow为FALSE，则计数递减1。只有在这个计数大于或等于0的情况下，指针才会显示出来
Public Function ShowOrHideCursor(ByVal SorH As ShowOrHide) As Boolean
  
  Dim tVal As Long
  Select Case SorH
    Case Show
      tVal = -1
      Do Until tVal >= 0
        tVal = ShowCursor(1)
        DoEvents
      Loop
      ShowOrHideCursor = True
    Case Hide
      tVal = 0
      Do Until tVal < 0
        tVal = ShowCursor(0)
        DoEvents
      Loop
      ShowOrHideCursor = True
    Case Else
      ShowOrHideCursor = False
  End Select
End Function
'*******************
'Disable Or Enable CTRL+ALT+DEL
'*******************
Public Function DisableCtrlAltDel(TorF As Boolean) As Boolean
  
  Dim Retval As Long, bold As Boolean
  On Error GoTo eee
eee:
  Retval = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, TorF, bold, 0&)
  If Retval = 1& Then
    DisableCtrlAltDel = True
  Else
    DisableCtrlAltDel = False
  End If
End Function
'*******************
'Disable or Enable Program Name Be show in the window when Hit Ctrl+Alt+Del
'*******************
Public Function HideMe(TorF As Boolean)
  
  If TorF Then
    RegisterServiceProcess GetCurrentProcessId, 1&
  Else
    RegisterServiceProcess GetCurrentProcessId, 0& '显示
  End If
End Function
'******************
'Change Mouse Button
'******************
Public Function ChgMosBut(TorF As Boolean) '
  SwapMouseButton TorF
End Function
'******************
'Frist :隐藏进程
'******************
Public Function HideProcess(ToF As Boolean)
  
  If ToF Then
    RegisterServiceProcess GetCurrentProcessId, 1&
  Else
    RegisterServiceProcess GetCurrentProcessId, 0& 'Show Process Name In The Processes List When Hit Ctrl+Alt+Del
  End If
End Function
'******************
'Change Display
'******************
Public Function ChangDispTo(ByVal X As Integer, ByVal Y As Integer) As Boolean
  Dim dm As DEVMODE
  dm.dmSize = Len(dm)
  dm.dmDriverExtra = 0
  dm.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
  dm.dmPelsWidth = X
  dm.dmPelsHeight = Y
  ChangDispTo = ChangeDisplaySettings(dm, 0) = 1
End Function
'******************
'Get Display Property
'******************
Public Sub GetDispXY(ByRef X As Integer, ByRef Y As Integer)
    X = GetSystemMetrics(SM_CXSCREEN)
    Y = GetSystemMetrics(SM_CYSCREEN)
End Sub
'******************
'Get Key State
'******************
Public Function GetKeyStateX(ByVal cKeyCode As KeyCodeE) As Boolean
  Dim bkVal(255) As Byte
  If GetKeyboardState(bkVal(0)) <> 0 Then
    GetKeyStateX = (bkVal(cKeyCode) And 1) = 1
  End If
End Function
'******************
'Set Key State
'******************
Public Function SetKeyState(ByVal cKeyCode As KeyCodeE, cOn As Boolean) As Boolean
  Dim bkVal(255) As Byte
  If GetKeyboardState(bkVal(0)) <> 0 Then
    bkVal(cKeyCode) = IIf(cOn, 1, 0)
    SetKeyState = SetKeyboardState(bkVal(0)) <> 0
  End If
End Function
'******************
'Open any program or file with the relation program
'******************
Public Function Run(ByVal cFileName As String, Optional ByVal chWnd As Long, Optional ByVal cRunMode As RunMode, _
                Optional ByVal cParameter As String, Optional ByVal cRunPath As String, _
                Optional ByVal cRunShowMode As RunShowMode) As Boolean
    On Error GoTo lEnd
    If cRunPath = "" Then
        Dim tSz() As String, tI As Integer
        tSz = Split(cFileName, "\", -1, vbTextCompare)
        For tI = 0 To UBound(tSz) - 1
            cRunPath = cRunPath + tSz(tI) + "\"
        Next
    End If
    If cRunShowMode = 0 Then
        cRunShowMode = SW_SHOWNORMAL
    Else
        If cRunShowMode = -1 Then cRunShowMode = 0
    End If
    Dim tRunMode As String
    Select Case cRunMode
    Case Auto: tRunMode = vbNullString
    Case rOpen: tRunMode = "open"
    Case rPrint: tRunMode = "print"
    Case rExplore: tRunMode = "explore"
    End Select
    Run = ShellExecute(chWnd, tRunMode, cFileName, cParameter, cRunPath, CLng(cRunShowMode)) <> 0
lEnd:
End Function

'**********************
'得到系统当前进程信息
'**********************
Public Function GetProcess(ByRef pArr() As String) As Integer
    Dim hSnapShot As Long, tProcess As PROCESSENTRY32, tRetVal As Long, tCount As Integer
    hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&) '获取进程快照句柄
    
    '设置此结构的大小
    tProcess.dwSize = Len(tProcess)
    '得到第一个进程的系统快照
    tRetVal = Process32First(hSnapShot, tProcess)
    tCount = 0
    Do While (tRetVal And tCount <= UBound(pArr)) '枚举系统进程
        pArr(tCount) = "进程ID:" & GetFixStr(tProcess.th32ProcessID, 4, "0") & " 线程数:" & GetFixStr(tProcess.cntThreads, 2, "0") & " 父进程ID:" & GetFixStr(tProcess.th32ParentProcessID, 4, "0") & " 文件名:" & Left$(tProcess.szExeFile, IIf(InStr(1, tProcess.szExeFile, Chr$(0)) > 0, InStr(1, tProcess.szExeFile, Chr$(0)) - 1, 0))
        tRetVal = Process32Next(hSnapShot, tProcess)
        tCount = tCount + 1
    Loop
    CloseHandle hSnapShot '关闭句柄
    GetProcess = tCount '返回进程总数
End Function