colorfunctions.bas

防红帽子的shell 我是从别处下的,喜欢的朋友自已

Attribute VB_Name = "ColorFunctions"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2006/11/10
'描    述：仿红帽子操作系统Shell
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Enum Style_
    [Longhorn]
    [Red_Hat]
    [XP_Blue]
    [XP_Green]
    [XP_Silver]
End Enum

Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Private Declare Function InvertRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Public Sub GetRGB(R As Integer, g As Integer, b As Integer, ByVal Color As Long)
    Dim TempValue As Long
    
    'First translate the color from a long v
    '     alue to a short value
    TranslateColor Color, 0, TempValue
    
    'Calculate the red, green, and blue valu
    '     es from the short value
    R = TempValue And &HFF&
    g = (TempValue And &HFF00&) / 2 ^ 8
    b = (TempValue And &HFF0000) / 2 ^ 16
End Sub

Public Function MakeGrey(ByVal Col As ColorConstants) As ColorConstants
    Dim R As Integer, g As Integer, b As Integer
    GetRGB R, g, b, Col 'EXTRACT COLOUR VARIABLES
    Dim x As Integer
    x = (R + g + b) / 3 'GET AVERAGE VALUE OF Each
    MakeGrey = RGB(x, x, x) 'Make the GREY colour
End Function


Public Function MakeBW(ByVal Col As ColorConstants) As ColorConstants
    Dim R As Integer, g As Integer, b As Integer
    GetRGB R, g, b, Col 'EXTRACT COLOUR VARIABLES
    Dim x As Integer
    x = (R + g + b) / 3 'GET AVERAGE VALUE OF Each


    If x < (255 / 2) Then x = 0 Else x = 255 'IF AVERAGE IS LESS THAN HALF OF MAX THEN
        'MAKE BLACK, ELSE MAKE WHITE
        MakeBW = RGB(x, x, x)
    End Function

Public Function AdjustBrightness(ByVal Color As Long, ByVal Amount As Single) As Long
    On Error Resume Next
    
    Dim R(1) As Integer, g(1) As Integer, b(1) As Integer
    
    'get red, green, and blue values
    GetRGB R(0), g(0), b(0), Color
    
    'add/subtract the amount to/from the ori
    '     ginal RGB values
    R(1) = SetBound(R(0) + Amount, 0, 255)
    g(1) = SetBound(g(0) + Amount, 0, 255)
    b(1) = SetBound(b(0) + Amount, 0, 255)
    
    'convert RGB back to Long value
    AdjustBrightness = RGB(R(1), g(1), b(1))
End Function

Private Function SetBound(ByVal Num As Single, ByVal MinNum As Single, ByVal MaxNum As Single) As Single
    If Num < MinNum Then
        SetBound = MinNum
    ElseIf Num > MaxNum Then
        SetBound = MaxNum
    Else
        SetBound = Num
    End If
End Function

Public Function InvertColor(ByVal hdc As Long, ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single)
    Dim hRect As RECT
    SetRect hRect, X1, Y1, X2, Y2
    InvertRect hdc, hRect
End Function