clssystem.cls

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

    
    'Make the form transparent
    If bytRate < 255 Then 'Set the transparence
        lWindowLong = lWindowLong Or WS_EX_LAYERED
        SetWindowLong lhWnd, GWL_EXSTYLE, lWindowLong
        SetLayeredWindowAttributes lhWnd, 0, bytRate, LWA_ALPHA
    Else                  'Reset the form
        lWindowLong = lWindowLong Xor WS_EX_LAYERED
        SetWindowLong lhWnd, GWL_EXSTYLE, lWindowLong
    End If
    
End Sub
    
Public Function fGetWinDir() As String
'**************************************************
'* Parameter   : NONE                             *
'* Return value: The windows directory path       *
'* Changed     : 03/25/2002                       *
'* Info        : Get the windows directory path.  *
'**************************************************

    'Variables
    Dim sBuffer As String
    
    'sCreate a buffer
    sBuffer = String(255, Chr(0))
    
    'Get the path
    fGetWinDir = Left(sBuffer, GetWindowsDirectory(sBuffer, Len(sBuffer)))
    
End Function

Public Sub sSetWallpaper( _
    ByVal sFilePath As String _
    )
'**************************************************
'* Parameter   : sFilePath: Path to the image     *
'* Return value: NONE                             *
'* Changed     : 03/25/2002                       *
'* Info        : Set a new desktop background.    *
'**************************************************

    'Set the new background
    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, sFilePath, SPIF_UPDATEINIFILE

End Sub

Public Function fGetSpecialFolder( _
    enmFOLDER As SPECIALFOLDERS _
    ) As String
'**************************************************
'* Parameter   : enmFOLDER: Folder to get         *
'* Return value: NONE                             *
'* Changed     : 05/23/2002                       *
'* Info        : Get the path of a special folder.*
'**************************************************

    'Variables
    Dim lResult As Long
    Dim sPath   As String
    Dim typITEM As ITEMIDLIST
    
    'Get the special folder
    lResult = SHGetSpecialFolderLocation(100, enmFOLDER, typITEM)
    
    'If no error occured
    If lResult = 0 Then
        sPath = Space(512)
        lResult = SHGetPathFromIDList(ByVal typITEM.mkid.cb, ByVal sPath)
        fGetSpecialFolder = Left(sPath, InStr(sPath, Chr(0)) - 1)
        Exit Function
    End If
    
    fGetSpecialFolder = ""
    
End Function

Public Function fGetPathLast( _
    sFilePath As String _
    ) As String
'**************************************************
'* Parameter   : sFilePath: Source path           *
'* Return value: The new path                     *
'* Changed     : 05/24/2002                       *
'* Info        : Go one path up from the source.  *
'**************************************************
    
    'Variables
    Dim nCount As Long
    
    'If it is a path
    If InStr(1, sFilePath, "\") Then
        For nCount = Len(sFilePath) To 0 Step -1
            If Mid(sFilePath, nCount, 1) = "\" Then
                fGetPathLast = Left(sFilePath, nCount - 1)
                Exit For
            End If
        Next
    Else
        'Return the path
        fGetPathLast = sFilePath
    End If
    
End Function

Public Function fGetFilenameFromPath( _
    sFilePath As String, _
    enmSplitMode As SPLITMODE _
    ) As String
'**************************************************
'* Parameter   : sFilePath   : String to check    *
'*               enmSplitMode: With extend.       *
'* Return value: The filename from a path         *
'* Changed     : 03/23/2002                       *
'* Info        : Get the filename from a path.    *
'**************************************************

On Error GoTo errError

    'Variables
    Dim nCount As Long
    Dim sFile  As String
    
    'If it is a whole path string
    If InStr(1, sFilePath, "\", vbTextCompare) <> 0 Then
        For nCount = Len(sFilePath) To 0 Step -1
            If Mid(sFilePath, nCount, 1) = "\" Then
                sFile = Right(sFilePath, Len(sFilePath) - nCount)
                Exit For
            End If
        Next
    Else 'or only a filename
        sFile = sFilePath
    End If
    
    'Should the Extension split away or not
    If (enmSplitMode = m_Both) Then
        fGetFilenameFromPath = sFile
        Exit Function
    ElseIf (enmSplitMode = m_Extension) Then
        'Check if a '.' exist
        If InStr(1, sFile, ".") <> 0 Then
            For nCount = Len(sFile) To 0 Step -1
                If Mid(sFile, nCount, 1) = "." Then
                    fGetFilenameFromPath = Right(sFile, Len(sFile) - nCount)
                    Exit For
                End If
            Next
        Else 'No '.' exist
            fGetFilenameFromPath = sFile
        End If
    ElseIf (enmSplitMode = m_Filename) Then
        'Do untiil the last '.'
        For nCount = Len(sFile) To 0 Step -1
            If Mid(sFile, nCount, 1) = "." Then
                fGetFilenameFromPath = Left(sFile, nCount - 1)
                Exit For
            End If
        Next
    End If
    
    Exit Function
        
errError:
    fGetFilenameFromPath = ""
    Exit Function

End Function

Public Function fExistFile( _
    sFilePath As String _
    ) As Boolean
'**************************************************
'* Parameter   : fFilePath: Path to the file      *
'* Return value: If the file exist (T/F)          *
'* Changed     : 03/23/2002                       *
'* Info        : Close the whole application.     *
'**************************************************

On Error GoTo errError

    'Check if it exist
    fExistFile = (Dir(sFilePath) <> "")

    Exit Function
        
errError:
    fExistFile = False
    Exit Function

End Function

Public Function fFunctionInDLLExist( _
    ByVal sDLLName As String, _
    ByVal sFunction As String _
    ) As Boolean
'**************************************************
'* Parameter   : sDLLName : Name of the DLL       *
'*               sFunction: Name of the function  *
'* Return value: Function exist                   *
'* Changed     : 08/03/2002                       *
'* Info        : Check if a function in a DLL     *
'*               exist.                           *
'**************************************************

    'Variables
    Dim hModule As Long
    Dim lProcAddress As Long
    
    'Try to load the dll
    hModule = LoadLibrary(sDLLName)
    
    'Found the DLL-Library
    If hModule <> 0 Then
        'Check if the function is available in the DLL
        lProcAddress = GetProcAddress(hModule, sFunction)
        FreeLibrary hModule
        'Returns the value
        fFunctionInDLLExist = CBool(lProcAddress)
    End If
  
End Function

Public Function fIsKeyPressedSpecial( _
    enmKeys As KEYSPRESSED _
    ) As Boolean
'**************************************************
'* Parameter   : enmKeys: Keys to check           *
'* Return value: Is the key pressed               *
'* Changed     : 08/03/2002                       *
'* Info        : Check if a key is pressed.       *
'**************************************************
    
    'Return the value
    fIsKeyPressedSpecial = CBool((GetKeyState(enmKeys) And &HF0000000))
    
End Function

Public Function fGetTaskbarPos( _
    ByVal enmTaskBar As TASKBAR _
    ) As Integer
'**************************************************
'* Parameter   : enmTaskBar: What way             *
'* Return value: The position                     *
'* Changed     : 08/21/2002                       *
'* Info        : Get the taskbars position.       *
'**************************************************
    
    'Variables
    Dim lResult   As Long
    Dim typAppBar As APPBARDATA

    'Get the positions
    lResult = SHAppBarMessage(ABM_GETTASKBARPOS, typAppBar)
    
    'Return the values
    With typAppBar.rc
        Select Case enmTaskBar
            Case enmBottom
                fGetTaskbarPos = .Bottom
            Case enmLeft
                fGetTaskbarPos = .Left
            Case enmRight
                fGetTaskbarPos = .Right
            Case enmtop
                fGetTaskbarPos = .Top
        End Select
    End With

End Function

Public Sub sSetFormRegion( _
    ByVal objForm As Form, _
    ByVal lTransparentColor As Long _
    )
'**************************************************
'* Parameter   : objSource        : Pic. object   *
'*               lTransparentColor: Trans. color  *
'* Return value: The regions handle               *
'* Changed     : 08/21/2002                       *
'* Info        : Set the region of a form.        *
'**************************************************
    
    'Variables
    Dim hRegion   As Long
    Dim lWinStyle As Long
    
    'Convert the system color to the normal RGB color
    If lTransparentColor < 0 Then OleTranslateColor lTransparentColor, 0&, lTransparentColor

    'Set the region
    If fFunctionInDLLExist("user32", "SetLayeredWindowAttributes") Then
        'Set the window style to layered
        lWinStyle = GetWindowLong(objForm.hwnd, GWL_EXSTYLE)
        lWinStyle = lWinStyle Or WS_EX_LAYERED
        SetWindowLong objForm.hwnd, GWL_EXSTYLE, lWinStyle
        SetLayeredWindowAttributes objForm.hwnd, lTransparentColor, 0&, LWA_COLORKEY
    End If
    
End Sub




'**************************************************
'*------------------------------------------------*
'*--------------------GET/LET---------------------*
'*------------------------------------------------*
'**************************************************

Public Property Get gGetColorDepth() As COLORDEPTH
'**************************************************
'* Changed     : 03/22/2002                       *
'* Special     : NONE                             *
'**************************************************

    'Returns the enum value
    gGetColorDepth = m_ColorDepth
    
End Property

Public Property Get gGetOS() As OPERATINGSYSTEM
'**************************************************
'* Changed     : 03/22/2002                       *
'* Special     : NONE                             *
'**************************************************

    'Returns the enum value
    gGetOS = m_OperatingSystem

End Property

Public Property Get gGetWinDir() As String
'**************************************************
'* Changed     : 03/25/2002                       *
'* Special     : NONE                             *
'**************************************************

    'Returns the win dir
    gGetWinDir = fGetWinDir

End Property