clssystem.cls

是游戏的很好的代码,为每个手写代码的开发者,游戏人才的开发也是这个的.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsSystem"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'**************************************************
'* Date   : 03/22/2002                            *
'* Name   : Matthias Bartelt                      *
'* Changed: 08/30/2002                            *
'* Info   : System functions/subs                 *
'**************************************************

'Variables must be declared
Option Explicit


'**************************************************
'*------------------------------------------------*
'*------------------DECLARATIONS------------------*
'*------------------------------------------------*
'**************************************************

'*** API
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal FunctionName As String) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal LibraryFileName As String) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegFlushKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Any) 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 Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueEx_Str Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal lPosX As Long, ByVal lPosY As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, crKey As Long, ByVal pblend As Long, ByVal dwFlags As Long) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Sub OleTranslateColor Lib "oleaut32.dll" (ByVal clr As Long, ByVal hpal As Long, ByRef lpcolorref As Long)


'*** Constants
Private Const ABM_GETTASKBARPOS = &H5
Private Const AC_DST_NO_ALPHA = &H20
Private Const AC_DST_NO_PREMULT_ALPHA = &H10
Private Const AC_SRC_ALPHA = &H1
Private Const AC_SRC_NO_ALPHA = &H2
Private Const AC_SRC_NO_PREMULT_ALPHA = &H1
Private Const AC_SRC_OVER = &H0
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0
Private Const ERROR_SUCCESS = 0&
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOPMOST = -1
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_READ = KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Private Const KEY_sCreate_LINK = &H20
Private Const KEY_sCreate_SUB_KEY = &H4
Private Const KEY_SET_VALUE = &H2
Private Const KEY_ALL_ACCESS = KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_sCreate_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_sCreate_LINK
Private Const LWA_ALPHA = &H2
Private Const LWA_COLORKEY = &H1
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_DWORD_BIG_ENDIAN = 5
Private Const REG_DWORD_LITTLE_ENDIAN = 4
Private Const REG_EXPAND_SZ = 2
Private Const REG_LINK = 6
Private Const REG_MULTI_SZ = 7
Private Const REG_NONE = 0
Private Const REG_OPTION_NON_VOLATILE = &H0
Private Const REG_SZ = 1
Private Const RGN_OR = 2
Private Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_UPDATEINIFILE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const ULW_ALPHA = &H2
Private Const ULW_COLORKEY = &H1
Private Const ULW_OPAQUE = &H4
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0
Private Const WS_EX_LAYERED = &H80000


'*** Enumss
Public Enum COLORDEPTH
    enmColorsUnknown = 0
    enmColors_1 = 1
    enmColors_16 = 2
    enmColors_256 = 3
    enmColors_16Mio = 4
    enmColors_24Mio = 5
    enmColors_32Mio = 6
End Enum
'---
Public Enum KEYSPRESSED
    VK_CONTROL = &H11
    VK_LCONTROL = &HA2
    VK_LMenu = &HA4
    VK_LSHIFT = &HA0
    VK_MENU = &H12
    VK_RCONTROL = &HA3
    VK_RMENU = &HA5
    VK_RSHIFT = &HA1
    VK_SHIFT = &H10
End Enum

'---
Public Enum REGROOTS
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_DYN_DATA = &H80000006
End Enum
'---
Public Enum OPERATINGSYSTEM
    enmOSUnknown = 0
    enmOSWin32s = 1
    enmOSWin95 = 2
    enmOSWinNT3 = 3
    enmOSWinNT4 = 4
    enmOSWin98 = 5
    enmOSWin98SE = 6
    enmOSWinME = 7
    enmOSWin2000 = 8
    enmOSWinXP = 9
End Enum
'---
Public Enum SPECIALFOLDERS
    WINDOWS = &H24
    TEMPLATES = &H15
    System = &H25
    STARTUP = &H7
    STARTMENU = &HB
    SENDTO = &H9
    RECENT = &H8
    PROGRAMS = &H2
    PROFILE = &H28
    Printers = &H4
    PERSONAL = &H5
    NETWORK = &H12
    MYPICTURES = &H27
    INTERNET = &H1
    Fonts = &H14
    FAVORITES = &H6
    DRIVES = &H11
    DESKTOP = &H0
    Controls = &H3
    CONNECTIONS = &H31
End Enum
'---
Public Enum SPLITMODE
    m_Filename = 0
    m_Extension = 1
    m_Both = 2
End Enum
'---
Public Enum TASKBAR
    enmBottom
    enmLeft
    enmRight
    enmtop
End Enum

'*** Types
Private Type BITMAPINFOHEADER
    biSize          As Long
    biWidth         As Long
    biHeight        As Long
    biPlanes        As Integer
    biBitCount      As Integer
    biCompression   As Long
    biSizeImage     As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed       As Long
    biClrImportant  As Long
End Type
'---
Private Type RGBQUAD
    rgbBlue         As Byte
    rgbGreen        As Byte
    rgbRed          As Byte
    rgbReserved     As Byte
End Type
'---
Private Type BITMAPINFO
    bmiHeader       As BITMAPINFOHEADER
    bmiColors       As RGBQUAD
End Type
'---
Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type
'---
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
'---
Private Type POINTAPI
    lPosX As Long
    lPosY As Long
End Type
'---
Private Type RECT
    Left             As Long
    Top              As Long
    Right            As Long
    Bottom           As Long
End Type
'---
Private Type APPBARDATA
    cbSize           As Long
    hwnd             As Long
    uCallbackMessage As Long
    uEdge            As Long
    rc               As RECT
    lParam           As Long
End Type
'---
Private Type Size
    cx As Long
    cy As Long
End Type
'---
Private Type SHITEMID
    cb As Long
    abID As Byte
End Type
'---
Private Type ITEMIDLIST
    mkid As SHITEMID
End Type

'*** Variables
Dim lWindowLong As Long
Dim m_ColorDepth      As COLORDEPTH
Dim m_OperatingSystem As OPERATINGSYSTEM



'**************************************************
'*------------------------------------------------*
'*-----------------FUNCTIONS/SUBS-----------------*
'*------------------------------------------------*
'**************************************************

Private Sub Class_Initialize()
'**************************************************
'* Parameter   : NONE                             *
'* Return value: NONE                             *
'* Changed     : 03/22/2002                       *
'* Info        : When the class is initializing.  *
'**************************************************

    'What system
    Call sGetOperatingSystem
    
    'What color depth
    Call sGetColorDepth
    
End Sub

Private Sub sGetColorDepth()
'**************************************************
'* Parameter   : NONE                             *
'* Return value: NONE                             *
'* Changed     : 03/22/2002                       *
'* Info        : Returns the color depth.         *
'**************************************************

    'Variables
    Dim lHDC        As Long
    Dim lPixelCount As Long
    Dim lResult     As Long

    'Get the main DC
    lHDC = GetDC(0)
    lPixelCount = GetDeviceCaps(lHDC, 14) * GetDeviceCaps(lHDC, 12)
    
    lResult = ReleaseDC(0, lHDC)
    
    'Get the depth
    Select Case lPixelCount
        Case 1: m_ColorDepth = enmColors_1
        Case 4: m_ColorDepth = enmColors_16
        Case 8: m_ColorDepth = enmColors_256
        Case 16: m_ColorDepth = enmColors_16Mio
        Case 24: m_ColorDepth = enmColors_24Mio
        Case 32: m_ColorDepth = enmColors_32Mio
        Case Else: m_ColorDepth = enmColorsUnknown
    End Select

End Sub

Private Sub sGetOperatingSystem()