clssystem.cls

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

'**************************************************
'* Parameter   : NONE                             *
'* Return value: NONE                             *
'* Changed     : 03/22/2002                       *
'* Info        : Returns the operationg system.   *
'**************************************************

    'Variables
    Dim lBuildNr     As Long
    Dim typOSVersion As OSVERSIONINFO
    
    'Reads the OS infos
    typOSVersion.dwOSVersionInfoSize = Len(typOSVersion)
    Call GetVersionEx(typOSVersion)
    
    'Set the default value
    m_OperatingSystem = enmOSUnknown
    
    'Read the actual version from the infos
    With typOSVersion
        'Set the right build number
        If (.dwBuildNumber And &HFFFF&) > &H7FFF Then
            lBuildNr = (.dwBuildNumber And &HFFFF&) - &H10000
        Else
            lBuildNr = .dwBuildNumber And &HFFFF&
        End If
        
        'Is it on a NT or normal platform
        If .dwPlatformId = VER_PLATFORM_WIN32_NT Then
            If .dwMajorVersion = 3 Then
                m_OperatingSystem = enmOSWinNT3
            ElseIf .dwMajorVersion = 4 Then
                m_OperatingSystem = enmOSWinNT4
            ElseIf .dwMajorVersion = 5 Then
                If .dwMinorVersion = 0 Then
                    m_OperatingSystem = enmOSWin2000
                ElseIf .dwMinorVersion = 1 Then
                    m_OperatingSystem = enmOSWinXP
                End If
            End If
        ElseIf .dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
            If (.dwMajorVersion > 4) Or (.dwMajorVersion = 4 And _
                .dwMinorVersion = 10) Then
                If lBuildNr = 1998 Then
                    m_OperatingSystem = enmOSWin98
                Else
                    m_OperatingSystem = enmOSWin98SE
                End If
            ElseIf (.dwMajorVersion = 4 And .dwMinorVersion = 0) Then
                m_OperatingSystem = enmOSWin95
            ElseIf (.dwMajorVersion = 4 And .dwMinorVersion = 90) Then
                m_OperatingSystem = enmOSWinME
            End If
        ElseIf .dwPlatformId = VER_PLATFORM_WIN32s Then
            m_OperatingSystem = enmOSWin32s
        End If
    End With
    
End Sub

Public Function fRegKeyExist( _
    lRoot As REGROOTS, _
    sKey As String _
    ) As Boolean
'**************************************************
'* Parameter   : lRoot: The regedit root          *
'*               sKey : Key to check              *
'* Return value: If the operation was successful  *
'* Changed     : 03/22/2002                       *
'* Info        : Check if a key in the registry   *
'*               exist.
'**************************************************

    'Variables
    Dim hKey    As Long
    Dim lResult As Long
    
    'Check if the key exist
    lResult = RegOpenKeyEx(lRoot, sKey, 0, KEY_READ, hKey)
    If lResult = ERROR_SUCCESS Then Call RegCloseKey(hKey)
    
    'Returns the value
    fRegKeyExist = (lResult = 0)
    
End Function

Public Function fRegKeyCreate( _
    lRoot As REGROOTS, _
    sNewKey As String _
    ) As Boolean
'**************************************************
'* Parameter   : lRoot   : The regedit root       *
'*               sNewKey : The new key name       *
'* Return value: If the operation was successful  *
'* Changed     : 03/22/2002                       *
'* Info        : sCreate a new key in the registry.*
'**************************************************

    'Variables
    Dim hKey       As Long
    Dim lRegResult As Long
    Dim lResult    As Long
    
    'Creates the new key
    lResult = RegCreateKeyEx(lRoot, sNewKey, 0, vbNullString, _
        REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRegResult)
        
    'Returns if the operation was successful
    If lResult = ERROR_SUCCESS Then
        lResult = RegFlushKey(hKey)
            If lResult = ERROR_SUCCESS Then Call RegCloseKey(hKey)
            fRegKeyCreate = (lRegResult <> 0)
    End If

End Function

Public Function fRegKeyDelete( _
    lRoot As REGROOTS, _
    sKey As String _
    ) As Boolean
'**************************************************
'* Parameter   : lRoot : The regedit root         *
'*               sKey  : Key to delete            *
'* Return value: If the operation was successful  *
'* Changed     : 03/22/2002                       *
'* Info        : Delete a key.                    *
'**************************************************

    'Delete the key and return if the operation was successful
    fRegKeyDelete = (RegDeleteKey(lRoot, sKey) = 0)
    
End Function

Public Function fRegValueDelete( _
    lRoot As REGROOTS, _
    sKey As String, _
    sField As String _
    ) As Boolean
'**************************************************
'* Parameter   : lRoot : The regedit root         *
'*               sKey  : Key to the value         *
'*               sField: Value to delete          *
'* Return value: If the operation was successful  *
'* Changed     : 03/22/2002                       *
'* Info        : Delete a value.                  *
'**************************************************

    'Variables
    Dim hKey    As Long
    Dim lResult As Long

    'Delete the values
    lResult = RegOpenKeyEx(lRoot, sKey, 0, KEY_ALL_ACCESS, hKey)
    If lResult = ERROR_SUCCESS Then
        lResult = RegDeleteValue(hKey, sField)
        lResult = RegCloseKey(hKey)
    End If
    
    'Returns if the operation was successful
    fRegValueDelete = (lResult = 0)
    
End Function

Public Function fRegValueSet( _
    lRoot As REGROOTS, _
    sKey As String, _
    sField As String, _
    vValue As Variant _
    ) As Boolean
'**************************************************
'* Parameter   : lRoot : The regedit root         *
'*               sKey  : Key to the value         *
'*               sField: Value to set             *
'*               vValue: The new value            *
'* Return value: If the operation was successful  *
'* Changed     : 03/22/2002                       *
'* Info        : Set a new value into the         *
'*               registry.                        *
'**************************************************

    'Variables
    Dim hKey    As Long
    Dim lResult As Long
    Dim lValue  As Long
    Dim sValue  As String
  
    'Wert in ein Feld der Registry schreiben
    lResult = RegOpenKeyEx(lRoot, sKey, 0, KEY_ALL_ACCESS, hKey)
    If lResult = ERROR_SUCCESS Then
      Select Case VarType(vValue)
        Case vbInteger, vbLong
            lValue = CLng(vValue)
            lResult = RegSetValueEx(hKey, sField, 0, REG_DWORD, _
                lValue, 4)
        Case vbString
            sValue = CStr(vValue)
            lResult = RegSetValueEx_Str(hKey, sField, 0, REG_SZ, sValue, _
            Len(sValue) + 1)
      End Select
      lResult = RegCloseKey(hKey)
    End If
    
    fRegValueSet = (lResult = 0)
    
End Function

Public Function fRegValueGet( _
    lRoot As REGROOTS, _
    sKey As String, _
    sField As String, _
    vValue As Variant _
    ) As Boolean
'**************************************************
'* Parameter   : lRoot : The regedit root         *
'*               sKey  : Key to the value         *
'*               sField: Value to get             *
'*               vValue: The value                *
'* Return value: If the operation was successful  *
'* Changed     : 03/22/2002                       *
'* Info        : Get a value from a field in the  *
'*               registry.                        *
'**************************************************

    'Variables
    Dim hKey    As Long
    Dim lBuffer As Long
    Dim lResult As Long
    Dim lType   As Long
    Dim sBuffer As String

    'Read the value from the registry
    lResult = RegOpenKeyEx(lRoot, sKey, 0, KEY_READ, hKey)
    If lResult = ERROR_SUCCESS Then
      lResult = RegQueryValueEx(hKey, sField, 0&, lType, ByVal _
        0&, lBuffer)
      If lResult = ERROR_SUCCESS Then
        Select Case lType
          Case REG_SZ
            sBuffer = Space(lBuffer + 1)
            lResult = RegQueryValueEx(hKey, sField, 0&, lType, _
                ByVal sBuffer, lBuffer)
            If lResult = ERROR_SUCCESS Then vValue = sBuffer
          Case REG_DWORD
            lResult = RegQueryValueEx(hKey, sField, 0&, lType, _
                lBuffer, lBuffer)
            If lResult = ERROR_SUCCESS Then vValue = lBuffer
        End Select
      End If
    End If
    
    If lResult = ERROR_SUCCESS Then lResult = RegCloseKey(hKey)
    fRegValueGet = (lResult = 0)
    
End Function

Public Function fINIRead( _
    ByVal sPath As String, _
    ByVal sSection As String, _
    ByVal sKey As String _
    ) As String
'**************************************************
'* Parameter   : sPath   : Path to the INI file   *
'*               sSection: Section to read        *
'*               sKey    : Key to read            *
'* Return value: The value from the INI           *
'* Changed     : 05/20/2002                       *
'* Info        : Read a INI file value.           *
'**************************************************

On Error GoTo errError

    'Variables
    Dim lResult As Long
    Dim sResult As String * 255

    'Read the value
    lResult = GetPrivateProfileString(sSection, sKey, "", sResult, 255, sPath)
    
    'Return the value
    If lResult <> 0 Then fINIRead = Left(sResult, lResult)

    Exit Function
    
errError:
    fINIRead = ""

End Function

Public Sub sINIWrite( _
    ByVal sPath As String, _
    ByVal sSection As String, _
    ByVal sKey As String, _
    ByVal sValue As String _
    )
'**************************************************
'* Parameter   : sPath   : Path to the INI file   *
'*               sSection: Section to read        *
'*               sKey    : Key to read            *
'*               svalue  : Value to write into
'* Return value: NON                              *
'* Changed     : 05/20/2002                       *
'* Info        : Write a INI file value.          *
'**************************************************

On Error Resume Next

    'Variables
    Dim lResult As Long
    
    'Write the value
    lResult = WritePrivateProfileString(sSection, sKey, sValue, sPath)
    
End Sub

Public Sub sSetFormOnTop( _
    lhWnd As Long, _
    Optional bOnTop As Boolean = True _
    )
'**************************************************
'* Parameter   : lhWnd : The window hWnd          *
'*               bOnTop: TRUE = on top            *
'* Return value: NONE                             *
'* Changed     : 03/22/2002                       *
'* Info        : Set a form always on top.        *
'**************************************************

    'Set the form on top or not
    SetWindowPos lhWnd, IIf((bOnTop), HWND_TOPMOST, HWND_NOTOPMOST), _
        0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE

End Sub

Public Sub sMakeFormTransparent( _
    lhWnd As Long, _
    bytRate As Byte _
    )
'**************************************************
'* Parameter   : lhWnd  : The window hWnd         *
'* Return value: bytRate: 0-255; Transparence     *
'* Changed     : 07/05/2002                       *
'* Info        : Makes a form transparent.        *
'**************************************************

    'Check the system
    If (gGetOS <> enmOSWin2000) And (gGetOS <> enmOSWinXP) Then Exit Sub

    lWindowLong = GetWindowLong(lhWnd, GWL_EXSTYLE)