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 Any, ByVal cbCopy As Long)
'***MANIPULATION FUNCTIONS***
Public Function GFColor_MixColor(ByVal Color1 As Long, ByVal Color2 As Long, ByVal 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 Long, ByVal 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 Long, ByVal 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 Long, ByVal 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 Long, ByVal 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 Long, ByRef R As Long, ByRef G As Long, ByRef 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 Long, ByVal 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]