GFColor/GFColormod.bas

Attribute VB_Name = "GFColormod"
Option Explicit
'(c)2001‑2003 by Louis. Use whenever special color effects are to be created.
'
'NOTE: use the name prefix 'GFColor_' as many functions are already
'implemented in projects (without 'GFColor_'), what could lead
'to name conflicts when adding GFColormod.
'
'NOTE: vars that save an R, G or B value of a color should have
'the var type Long (e.g. 'Dim R as Long'), not Byte.
'Although the value range of Byte would be sufficient for storing color values
'errors could occur when calculations are done.
'
'NOTE: it is important to verify R, G and B values as they could exceed
'255 if a Windows system color was passed to the current function.
'
'HIWORD, LOWORD
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As AnyByVal cbCopy As Long)

'***MANIPULATION FUNCTIONS***

Public Function GFColor_MixColor(ByVal Color1 As LongByVal Color2 As LongByVal Ratio As Single) As Long
    'On Error resume next 'returns a mixture of both colors in the ratio Ratio
    Dim R1 As Long
    Dim R2 As Long
    Dim G1 As Long
    Dim G2 As Long
    Dim B1 As Long
    Dim B2 As Long
    'verify
    If (HIWORD(Color1) = &H8000) Or (HIWORD(Color2) = &H8000) Then
        GFColor_MixColor = Color1 'return color 1 in case of an error
        Exit Function
    End If
    'begin
    Call GFColor_ReRGB(Color1, R1, G1, B1)
    Call GFColor_ReRGB(Color2, R2, G2, B2)
    GFColor_MixColor = RGB( _
        CLng(CSng(R1) * Ratio + CSng(R2) * (1! ‑ Ratio)), _
        CLng(CSng(G1) * Ratio + CSng(G2) * (1! ‑ Ratio)), _
        CLng(CSng(B1) * Ratio + CSng(B2) * (1! ‑ Ratio)))
    Exit Function
End Function

Public Function GFColor_ToBlackWhite(ByVal InputColor As Long) As Long
    'On Error resume next
    Dim R As Long
    Dim G As Long
    Dim B As Long
    'verify
    If HIWORD(InputColor) = &H8000 Then
        GFColor_ToBlackWhite = InputColor
        Exit Function
    End If
    'begin
    Call GFColor_ReRGB(InputColor, R, G, B)
    R = (R + G + B) \ 3&
    G = R
    B = R
    If R < 0& Then R = 0&: If R > 255& Then R = 255&
    If G < 0& Then G = 0&: If G > 255& Then G = 255&
    If B < 0& Then B = 0&: If B > 255& Then B = 255&
    GFColor_ToBlackWhite = RGB(R, G, B)
    Exit Function
End Function

Public Function GFColor_ToBlackWhiteShadowColor(ByVal InputColor As Long) As Long
    'On Error resume next 'returns a black & white shadow color
    InputColor = GFColor_ToBlackWhite(InputColor)
    If GFColor_IsBrightnessChangable(InputColor, ‑128) Then
        GFColor_ToBlackWhiteShadowColor = _
            GFColor_ChangeBrightness(InputColor, ‑128)
    Else
        GFColor_ToBlackWhiteShadowColor = _
            GFColor_ChangeBrightness(InputColor, 128)
    End If
End Function

Public Function GFColor_ChangeContrast(ByVal InputColor As LongByVal DistanceMultiplicator As Single) As Long
    'On Error resume next
    Dim R As Long
    Dim G As Long
    Dim B As Long
    'verify
    If HIWORD(InputColor) = &H8000 Then
        GFColor_ChangeContrast = InputColor
        Exit Function
    End If
    'begin
    Call GFColor_ReRGB(InputColor, R, G, B)
    R = 128& + CLng(CSng(128& ‑ R) * DistanceMultiplicator)
    G = 128& + CLng(CSng(128& ‑ G) * DistanceMultiplicator)
    B = 128& + CLng(CSng(128& ‑ B) * DistanceMultiplicator)
    If R < 0& Then R = 0&: If R > 255& Then R = 255&
    If G < 0& Then G = 0&: If G > 255& Then G = 255&
    If B < 0& Then B = 0&: If B > 255& Then B = 255&
    GFColor_ChangeContrast = RGB(R, G, B)
    Exit Function
End Function

Public Function GFColor_ChangeBrightness(ByVal InputColor As LongByVal PlusMinus As Long) As Long
    'On Error resume next
    Dim R As Long
    Dim G As Long
    Dim B As Long
    'verify
    If HIWORD(InputColor) = &H8000 Then
        GFColor_ChangeBrightness = InputColor
        Exit Function
    End If
    'begin
    Call GFColor_ReRGB(InputColor, R, G, B)
    R = R + PlusMinus
    G = G + PlusMinus
    B = B + PlusMinus
    If R < 0& Then R = 0&: If R > 255& Then R = 255&
    If G < 0& Then G = 0&: If G > 255& Then G = 255&
    If B < 0& Then B = 0&: If B > 255& Then B = 255&
    GFColor_ChangeBrightness = RGB(R, G, B)
    Exit Function
End Function

Public Function GFColor_IsBrightnessChangable(ByVal InputColor As LongByVal PlusMinus As Long) As Boolean
    'On Error resume next 'returns True if brightness can be adjusted without changing color (RGB relation), False if not
    Dim R As Long
    Dim G As Long
    Dim B As Long
    'verify
    If HIWORD(InputColor) = &H8000 Then
        GFColor_IsBrightnessChangable = False 'error, nothing to change
        Exit Function
    End If
    'begin
    Call GFColor_ReRGB(InputColor, R, G, B)
'    R = R + PlusMinus
'    G = G + PlusMinus
'    B = B + PlusMinus
'    If (R < 0&) Or (R > 255&) Then
'        GFColor_IsBrightnessChangable = False
'        Exit Function
'    End If
'    If (G < 0&) Or (G > 255&) Then
'        GFColor_IsBrightnessChangable = False
'        Exit Function
'    End If
'    If (B < 0&) Or (B > 255&) Then
'        GFColor_IsBrightnessChangable = False
'        Exit Function
'    End If
    If PlusMinus > 0 Then
        GFColor_IsBrightnessChangable = ((R + G + B) \ 3&) <= 127&
    Else
        GFColor_IsBrightnessChangable = ((R + G + B) \ 3&) >= 127&
    End If
    Exit Function
End Function

Public Function GFColor_InvertColor(ByVal InputColor As Long) As Long
    'On Error resume next 'returns 'negative' of passed color; do not (!) pass Windows colors (negative values)
    Dim R As Long
    Dim G As Long
    Dim B As Long
    'verify
    If HIWORD(InputColor) = &H8000 Then
        GFColor_InvertColor = InputColor 'error, nothing to invert
        Exit Function
    End If
    'begin
    Call GFColor_ReRGB(InputColor, R, G, B)
    R = 255& ‑ R
    G = 255& ‑ G
    B = 255& ‑ B
    GFColor_InvertColor = RGB(R, G, B)
    Exit Function
End Function

Public Function GFColor_InvertColorSave(ByVal InputColor As Long) As Long
    'On Error resume next 'returns 'negative' of passed color, use extended function to verify that inverted color is not input color (grey)
    Dim R As Long
    Dim G As Long
    Dim B As Long
    'verify
    If HIWORD(InputColor) = &H8000 Then
        GFColor_InvertColorSave = InputColor 'error, nothing to invert
        Exit Function
    End If
    'begin
    Call GFColor_ReRGB(InputColor, R, G, B)
    If (R < 100) Or (R > 156) Then R = 255& ‑ R Else R = 156
    If (G < 100) Or (G > 156) Then G = 255& ‑ G Else G = 156
    If (B < 100) Or (B > 156) Then B = 255& ‑ B Else B = 156
    GFColor_InvertColorSave = RGB(R, G, B)
    Exit Function
End Function

'***END OF MANIPULATION FUNCTIONS***
'***CHECKING FUNCTIONS***

Public Function GFColor_IsColorEqual(ByVal Color1 As LongByVal Color2 As Long) As Boolean
    'On Error resume next 'returns True if the passed colors are hardly distinguishable, False if they look different
    Dim R1 As Long
    Dim R2 As Long
    Dim G1 As Long
    Dim G2 As Long
    Dim B1 As Long
    Dim B2 As Long
    Dim AbsValueMin As Long
    'verify
    If (HIWORD(Color1) = &H8000) Or (HIWORD(Color2) = &H8000) Then
        GFColor_IsColorEqual = (Color1 = Color2) 'error, check at least if same system color
        Exit Function
    End If
    'preset
    Call GFColor_ReRGB(Color1, R1, G1, B1)
    Call GFColor_ReRGB(Color2, R2, G2, B2)
    '
    'NOTE: reading a text in dark colors only is harder than in light ones,
    'especially when the monitor brightness and contrast is low.
    '
    AbsValueMin = 24& + (104& ‑ CLng(CSng((R1 + G1 + B1 + R2 + G2 + B2) / 6&) / 255! * 104!)) 'algorithm tested for rather good
    GFColor_IsColorEqual = ((Abs(R1 ‑ R2) + Abs(G1 ‑ G2) + Abs(B1 ‑ B2)) < AbsValueMin * 3&)
    Exit Function
End Function

'***END OF CHECKING FUNCTIONS***
'***CONVERSION FUNCTIONS***

Public Sub GFColor_ReRGB(ByVal RGB As LongByRef R As LongByRef G As LongByRef B As Long)
    'On Error Resume Next 'opposite of RGB()
    B = Int(RGB / (256& ^ 2&))
    RGB = RGB ‑ B * (256& ^ 2&)
    G = Int(RGB / (256& ^ 1&))
    RGB = RGB ‑ G * (256& ^ 1&)
    R = Int(RGB / (256& ^ 0&))
    RGB = RGB ‑ R * (256& ^ 0&)
    If R < 0& Then R = 0& 'verifying is important when passing Windows system colors
    If R > 255& Then R = 255&
    If G < 0& Then G = 0&
    If G > 255& Then G = 255&
    If B < 0& Then B = 0&
    If B > 255& Then B = 255&
End Sub

Public Function COLORTOSTRING(ByVal Color As Long) As String 'created out of ReRGB()
    'On Error Resume Next
    Dim R As Long
    Dim G As Long
    Dim B As Long
    'verify
    If Color < 0 Then
        '
        'NOTE: 'pass through' negative values as they are like variable names
        'for Windows system colors and thus cannot be converted.
        '
        COLORTOSTRING = LTrim$(Str$(Color))
        Exit Function
    End If
    'begin
    B = Int(Color / (256& ^ 2&))
    Color = Color ‑ B * (256& ^ 2&)
    G = Int(Color / (256& ^ 1&))
    Color = Color ‑ G * (256& ^ 1&)
    R = Int(Color / (256& ^ 0&))
    Color = Color ‑ R * (256& ^ 0&)
    If R < 0& Then R = 0&
    If R > 255& Then R = 255&
    If G < 0& Then G = 0&
    If G > 255& Then G = 255&
    If B < 0& Then B = 0&
    If B > 255& Then B = 255&
    COLORTOSTRING = LTrim$(Str$(R)) + "," + LTrim$(Str$(G)) + "," + LTrim$(Str$(B))
    Exit Function
End Function

Public Function STRINGTOCOLOR(ByVal RGBString As String) As Long
    'On Error Resume Next 'use in any project
    Dim R As Long
    Dim G As Long
    Dim B As Long
    Dim Temp As Long
    'verify
    If Mid$(LTrim$(RGBString), 1, 1) = "‑" Then
        '
        'NOTE: 'pass through' negative values as they are like variable names
        'for Windows system colors and cannot be converted.
        '
        STRINGTOCOLOR = Val(LTrim$(RGBString))
        Exit Function
    End If
    'begin
    For Temp = 1 To Len(RGBString)
        If Mid$(RGBString, Temp, 1) = "," Then
            R = Val(Trim$(Left$(RGBString, MIN(Temp ‑ 1, 3)))) 'limit number length to 3 to avoid overflow
            RGBString = Right$(RGBString, Len(RGBString) ‑ Temp)
            Exit For
        End If
    Next Temp
    For Temp = 1 To Len(RGBString)
        If Mid$(RGBString, Temp, 1) = "," Then
            G = Val(Trim$(Left$(RGBString, MIN(Temp ‑ 1, 3)))) 'limit number length to 3 to avoid overflow
            RGBString = Right$(RGBString, Len(RGBString) ‑ Temp)
            Exit For
        End If
    Next Temp
    If Len(RGBString) > 3 Then RGBString = Left$(RGBString, 3) 'limit number length to 3 to avoid overflow
    B = Val(Trim$(RGBString))
    If R < 0& Then R = 0&
    If R > 255& Then R = 255&
    If G < 0& Then G = 0&
    If G > 255& Then G = 255&
    If B < 0& Then B = 0&
    If B > 255& Then B = 255&
    STRINGTOCOLOR = RGB(R, G, B)
    Exit Function
End Function

Public Function GFColor_COLORTOSTRING(ByVal Color As Long) As String 'created out of ReRGB()
    'On Error Resume Next 'creates a string of the format 'r,g,b'
    Dim R As Long
    Dim G As Long
    Dim B As Long
    'begin
    B = Int(Color / (256& ^ 2&))
    Color = Color ‑ B * (256& ^ 2&)
    G = Int(Color / (256& ^ 1&))
    Color = Color ‑ G * (256& ^ 1&)
    R = Int(Color / (256& ^ 0&))
    Color = Color ‑ R * (256& ^ 0&)
    If R < 0& Then R = 0&
    If R > 255& Then R = 255&
    If G < 0& Then G = 0&
    If G > 255& Then G = 255&
    If B < 0& Then B = 0&
    If B > 255& Then B = 255&
    GFColor_COLORTOSTRING = LTrim$(Str$(R)) + "," + LTrim$(Str$(G)) + "," + LTrim$(Str$(B))
End Function

Private Function GFColor_STRINGTOCOLOR(ByVal RGBString As String) As Long
    'On Error Resume Next 'passed string must have the format 'r,g,b'
    Dim R As Long
    Dim G As Long
    Dim B As Long
    Dim Temp As Long
    'begin
    For Temp = 1 To Len(RGBString)
        If Mid$(RGBString, Temp, 1) = "," Then
            R = Val(Trim$(Left$(RGBString, MIN(Temp ‑ 1, 3)))) 'limit number length to 3 to avoid overflow
            RGBString = Right$(RGBString, Len(RGBString) ‑ Temp)
            Exit For
        End If
    Next Temp
    For Temp = 1 To Len(RGBString)
        If Mid$(RGBString, Temp, 1) = "," Then
            G = Val(Trim$(Left$(RGBString, MIN(Temp ‑ 1, 3)))) 'limit number length to 3 to avoid overflow
            RGBString = Right$(RGBString, Len(RGBString) ‑ Temp)
            Exit For
        End If
    Next Temp
    If Len(RGBString) > 3 Then RGBString = Left$(RGBString, 3) 'limit number length to 3 to avoid overflow
    B = Val(Trim$(RGBString))
    If R < 0& Then R = 0& 'verify (important)
    If R > 255& Then R = 255&
    If G < 0& Then G = 0&
    If G > 255& Then G = 255&
    If B < 0& Then B = 0&
    If B > 255& Then B = 255&
    GFColor_STRINGTOCOLOR = RGB(R, G, B)
End Function

'***END OF CONVERSION FUNCTIONS***
'***OTHER***

Private Function LOWORD(ByVal n As Long) As Integer
    'On Error Resume Next '(truly) returns the low word of n
    Call CopyMemory(LOWORD, ByVal VarPtr(n) + 0, 2)
End Function

Private Function HIWORD(ByVal n As Long) As Integer
    'On Error Resume Next '(truly) returns the high word of n
    Call CopyMemory(HIWORD, ByVal VarPtr(n) + 2, 2)
End Function

Private Function MIN(ByVal Value1 As LongByVal Value2 As Long) As Long
    'On Error Resume Next
    If Value1 < Value2 Then
        MIN = Value1
    Else
        MIN = Value2
    End If
End Function

'
'Stuff by Richard Moss [mailto:richard@cyotek.com].
'Could be implemented if necessary.
'
'Declare Function GetSysColor& Lib "user32" (ByVal nIndex As Long)
'
''##SUMMARY Converts a system color into an RGB color
''##UPDATE_NOTE
'Public Function TranslateColor(ByVal Color As OLE_COLOR) As Long
'    On Error Resume Next
'        If (Color And &H80000000) = &H80000000 Then
'            TranslateColor = GetSysColor(Color And &HFF)
'         Else
'            TranslateColor = Color
'         End If
'    On Error GoTo 0
'End Function '(Public) Function TranslateColor () As Long
'
'As far as this code goes, just pass in a color and it will return an RGB
'based color. If you pass in an RGB color, it will be returned as is, whereas
'if you pass an OLE_COLOR such as vbButtonFace, the RGB equivalent will be
'used. You could also use the OleTranslateColor API (I used to use this
'before switching to the above for reasons I can't even remember :(, I think
'it was something to do with the ole color types which were defined after VB6
'came out, ie those for hot tracking and the like but I really can't
'remember) instead of the bit which checks the hiword for system colors, but
'it 's just another API to declare if so.
'


[END OF FILE]