Attribute VB_Name = "modUtility"
'Flamebird MX
'Copyright (C) 2003-2007 Flamebird Team
'Contact:
' JaViS: javisarias@ gmail.com (JaViS)
' Danko: lord_danko@users.sourceforge.net (Darío Cutillas)
' Zubiaurre: izubiaurre@users.sourceforge.net (Imanol Zubiaurre)
'
'This program is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published by
'the Free Software Foundation; either version 2 of the License, or
'(at your option) any later version.
'
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'GNU General Public License for more details.
Option Explicit
'Public Type RECT
' left As Long
' top As Long
' right As Long
' bottom As Long
'End Type
Private Type TRIVERTEX
X As Long
Y As Long
Red As Integer
Green As Integer
Blue As Integer
Alpha As Integer
End Type
Private Type GRADIENT_RECT
UpperLeft As Long
LowerRight As Long
End Type
Private Type GRADIENT_TRIANGLE
Vertex1 As Long
Vertex2 As Long
Vertex3 As Long
End Type
Private Declare Function GradientFill Lib "msimg32" ( _
ByVal hdc As Long, _
pVertex As TRIVERTEX, _
ByVal dwNumVertex As Long, _
pMesh As GRADIENT_RECT, _
ByVal dwNumMesh As Long, _
ByVal dwMode As Long) As Long
Private Declare Function GradientFillTriangle Lib "msimg32" Alias "GradientFill" ( _
ByVal hdc As Long, _
pVertex As TRIVERTEX, _
ByVal dwNumVertex As Long, _
pMesh As GRADIENT_TRIANGLE, _
ByVal dwNumMesh As Long, _
ByVal dwMode As Long) As Long
Private Const GRADIENT_FILL_TRIANGLE = &H2&
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Public Const CLR_INVALID = -1
Public Enum GradientFillRectType
GRADIENT_FILL_RECT_H = 0
GRADIENT_FILL_RECT_V = 1
End Enum
Public Sub RGBToHLS( _
ByVal r As Long, ByVal g As Long, ByVal b As Long, _
h As Single, s As Single, l As Single _
)
Dim max As Single
Dim min As Single
Dim delta As Single
Dim rR As Single, rG As Single, rB As Single
rR = r / 255: rG = g / 255: rB = b / 255
'{Given: rgb each in [0,1].
' Desired: h in [0,360] and s in [0,1], except if s=0, then h=UNDEFINED.}
max = Maximum(rR, rG, rB)
min = Minimum(rR, rG, rB)
l = (max + min) / 2 '{This is the lightness}
'{Next calculate saturation}
If max = min Then
'begin {Acrhomatic case}
s = 0
h = 0
'end {Acrhomatic case}
Else
'begin {Chromatic case}
'{First calculate the saturation.}
If l <= 0.5 Then
s = (max - min) / (max + min)
Else
s = (max - min) / (2 - max - min)
End If
'{Next calculate the hue.}
delta = max - min
If rR = max Then
h = (rG - rB) / delta '{Resulting color is between yellow and magenta}
ElseIf rG = max Then
h = 2 + (rB - rR) / delta '{Resulting color is between cyan and yellow}
ElseIf rB = max Then
h = 4 + (rR - rG) / delta '{Resulting color is between magenta and cyan}
End If
'Debug.Print h
'h = h * 60
'If h < 0# Then
' h = h + 360 '{Make degrees be nonnegative}
'End If
'end {Chromatic Case}
End If
'end {RGB_to_HLS}
End Sub
Public Sub HLSToRGB( _
ByVal h As Single, ByVal s As Single, ByVal l As Single, _
r As Long, g As Long, b As Long _
)
Dim rR As Single, rG As Single, rB As Single
Dim min As Single, max As Single
If s = 0 Then
' Achromatic case:
rR = l: rG = l: rB = l
Else
' Chromatic case:
' delta = Max-Min
If l <= 0.5 Then
's = (Max - Min) / (Max + Min)
' Get Min value:
min = l * (1 - s)
Else
's = (Max - Min) / (2 - Max - Min)
' Get Min value:
min = l - s * (1 - l)
End If
' Get the Max value:
max = 2 * l - min
' Now depending on sector we can evaluate the h,l,s:
If (h < 1) Then
rR = max
If (h < 0) Then
rG = min
rB = rG - h * (max - min)
Else
rB = min
rG = h * (max - min) + rB
End If
ElseIf (h < 3) Then
rG = max
If (h < 2) Then
rB = min
rR = rB - (h - 2) * (max - min)
Else
rR = min
rB = (h - 2) * (max - min) + rR
End If
Else
rB = max
If (h < 4) Then
rR = min
rG = rR - (h - 4) * (max - min)
Else
rG = min
rR = (h - 4) * (max - min) + rG
End If
End If
End If
r = rR * 255: g = rG * 255: b = rB * 255
End Sub
Private Function Maximum(rR As Single, rG As Single, rB As Single) As Single
If (rR > rG) Then
If (rR > rB) Then
Maximum = rR
Else
Maximum = rB
End If
Else
If (rB > rG) Then
Maximum = rB
Else
Maximum = rG
End If
End If
End Function
Private Function Minimum(rR As Single, rG As Single, rB As Single) As Single
If (rR < rG) Then
If (rR < rB) Then
Minimum = rR
Else
Minimum = rB
End If
Else
If (rB < rG) Then
Minimum = rB
Else
Minimum = rG
End If
End If
End Function
Public Sub GradientFillRect( _
ByVal lHdc As Long, _
tr As RECT, _
ByVal oStartColor As OLE_COLOR, _
ByVal oEndColor As OLE_COLOR, _
ByVal eDir As GradientFillRectType _
)
Dim hBrush As Long
Dim lStartColor As Long
Dim lEndColor As Long
Dim lr As Long
' Use GradientFill:
lStartColor = TranslateColor(oStartColor)
lEndColor = TranslateColor(oEndColor)
Dim tTV(0 To 1) As TRIVERTEX
Dim tGR As GRADIENT_RECT
setTriVertexColor tTV(0), lStartColor
tTV(0).X = tr.Left
tTV(0).Y = tr.Top
setTriVertexColor tTV(1), lEndColor
tTV(1).X = tr.Right
tTV(1).Y = tr.Bottom
tGR.UpperLeft = 0
tGR.LowerRight = 1
GradientFill lHdc, tTV(0), 2, tGR, 1, eDir
If (Err.Number <> 0) Then
' Fill with solid brush:
hBrush = CreateSolidBrush(TranslateColor(oEndColor))
FillRect lHdc, tr, hBrush
DeleteObject hBrush
End If
End Sub
Private Sub setTriVertexColor(tTV As TRIVERTEX, lColor As Long)
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
lRed = (lColor And &HFF&) * &H100&
lGreen = (lColor And &HFF00&)
lBlue = (lColor And &HFF0000) \ &H100&
setTriVertexColorComponent tTV.Red, lRed
setTriVertexColorComponent tTV.Green, lGreen
setTriVertexColorComponent tTV.Blue, lBlue
End Sub
Private Sub setTriVertexColorComponent(ByRef iColor As Integer, ByVal lComponent As Long)
If (lComponent And &H8000&) = &H8000& Then
iColor = (lComponent And &H7F00&)
iColor = iColor Or &H8000
Else
iColor = lComponent
End If
End Sub
Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
Optional hPal As Long = 0) As Long
' Convert Automation color to Windows color
If OleTranslateColor(oClr, hPal, TranslateColor) Then
TranslateColor = CLR_INVALID
End If
End Function
