VB Colour Converter

[appdalesolution]

Hi, Just a peice of software to convert colour codes, as i couldnt find anything to do what i wanted on the net i wrote my own. This is useful when converting HTML Hex or RGB values to VB Hex or visa versa.

The app is free to download and use as much as you like

Please let me know if this programs works properly as im not sure the installer installls all components.

Also any additions or error in the program please report to leedale@appdalesolutions.com

http://www.appdalesolutions.com/software/appdalecolourconverter.zip

Thanks!

[DarkX_Greece]

Very nice appdalesolution! :) :) :) :)

[appdalesolution]

Thanks glad you liked it!

i have been infomed that there is an error with the installer which i have fixed now.

[appdalesolution]

heres the code for the app:

frmConverter:

Option Explicit

'---------------------------------------------------------------------------------------
' Procedure : RgbToHls
' DateTime : 11/02/2005 11:18
' Author : www.vb-helper.com
' Purpose : Take RGB values and return corresponding HLS values as ByRef variables
'---------------------------------------------------------------------------------------

Private Sub RgbToHls(ByVal r As Double, ByVal g As Double, _
ByVal b As Double, ByRef H As Double, ByRef L As _
Double, ByRef S As Double)

Dim max As Double
Dim min As Double
Dim diff As Double
Dim r_dist As Double
Dim g_dist As Double
Dim b_dist As Double

On Error GoTo RgbToHls_Error

' Get the maximum and minimum RGB components.
max = r
If max < g Then max = g
If max < b Then max = b

min = r
If min > g Then min = g
If min > b Then min = b

diff = max - min
L = (max + min) / 2
If Abs(diff) < 0.00001 Then
S = 0
H = 0 ' H is really undefined.
Else
If L <= 0.5 Then
S = diff / (max + min)
Else
S = diff / (2 - max - min)
End If

r_dist = (max - r) / diff
g_dist = (max - g) / diff
b_dist = (max - b) / diff

If r = max Then
H = b_dist - g_dist
ElseIf g = max Then
H = 2 + r_dist - b_dist
Else
H = 4 + g_dist - r_dist
End If

H = H * 60
If H < 0 Then H = H + 360
End If

On Error GoTo 0
Exit Sub

RgbToHls_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Sub

Private Sub cmdExit_Click()
End
End Sub

Private Sub Form_Load()
staMain.Panels(1).Text = "Version: " & App.Major & "." & App.Minor & "." & App.Revision
End Sub

Private Sub mniFileExit_Click()
Call cmdExit_Click
End Sub

Private Sub mnuHelpAbout_Click()
frmAbout.Show vbModal
End Sub

Private Sub sliBlue_Change()
txtBlue.Text = sliBlue.Value
End Sub

Private Sub sliBlue_Scroll()
Call sliBlue_Change
End Sub

Private Sub sliGreen_Change()
txtGreen.Text = sliGreen.Value
End Sub

Private Sub sliGreen_Scroll()
Call sliGreen_Change
End Sub

Private Sub sliHue_Change()
txtHue.Text = sliHue.Value
End Sub

Private Sub sliHue_Scroll()
Call sliHue_Change
End Sub

Private Sub sliLight_Change()
txtLight.Text = sliLight.Value / 100
End Sub

Private Sub sliLight_Scroll()
Call sliLight_Change
End Sub

Private Sub sliRed_Change()
txtRed.Text = sliRed.Value
End Sub

Private Sub sliRed_Scroll()
Call sliRed_Change
End Sub

Private Sub sliSaturation_Change()
txtSaturation.Text = sliSaturation.Value / 100
End Sub

Private Sub sliSaturation_Scroll()
Call sliSaturation_Change
End Sub

Private Sub txtBlue_Change()
On Error GoTo txtBlue_Change_Error

If frmConverter.ActiveControl = txtBlue Then
If Not txtBlue.Text = "" Then
If IsNumeric(txtBlue.Text) Then
If CInt(txtBlue.Text) <= 255 And CInt(txtBlue.Text) >= 0 Then
Call ChangeColour(False)
Else
If CInt(txtBlue.Text) > 255 Then
txtBlue.Text = 255
End If
If CInt(txtBlue.Text) < 0 Then
txtBlue.Text = 0
End If
End If
End If
End If
End If

On Error GoTo 0
Exit Sub

txtBlue_Change_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Sub

Private Sub txtGreen_Change()
On Error GoTo txtGreen_Change_Error

If frmConverter.ActiveControl = txtGreen Then
If Not txtGreen.Text = "" Then
If IsNumeric(txtGreen.Text) Then
If CInt(txtGreen.Text) <= 255 And CInt(txtGreen.Text) >= 0 Then
Call ChangeColour(False)
Else
If CInt(txtGreen.Text) > 255 Then
txtGreen.Text = 255
End If
If CInt(txtGreen.Text) < 0 Then
txtGreen.Text = 0
End If
End If
End If
End If
End If

On Error GoTo 0
Exit Sub

txtGreen_Change_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Sub

Private Sub txtHex_Change()
Dim sRGBValue As String

On Error GoTo txtHex_Change_Error

If frmConverter.ActiveControl = txtHex Then
If Left(txtHex, 1) = "#" Then
If Len(txtHex) = 7 Then
sRGBValue = HEXCOL2RGB(txtHex)
txtRed.Text = Left(sRGBValue, 3)
txtGreen.Text = Mid(sRGBValue, 4, 3)
txtBlue.Text = Right(sRGBValue, 3)
Call ChangeColour(False)
End If
End If
End If

On Error GoTo 0
Exit Sub

txtHex_Change_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Sub

Private Sub txtHue_Change()
On Error GoTo txtHue_Change_Error

If frmConverter.ActiveControl = txtHue Then
If Not txtHue = "" Then
If IsNumeric(txtLight.Text) Then
If CInt(txtHue.Text) <= 360 And CInt(txtHue.Text) >= 0 Then
Call ChangeColour(True)
Else
If CInt(txtHue.Text) > 360 Then
txtHue.Text = 360
End If
If CInt(txtHue.Text) < 0 Then
txtHue.Text = 0
End If
End If
End If
End If
End If

On Error GoTo 0
Exit Sub

txtHue_Change_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Sub

Private Sub txtLight_Change()

On Error GoTo txtLight_Change_Error

If frmConverter.ActiveControl = txtLight Then
If Not txtLight = "" Then
If IsNumeric(txtLight.Text) Then
If CInt(txtLight.Text) <= 1 And CInt(txtLight.Text) >= 0 Then
Call ChangeColour(True)
Else
If CInt(txtLight.Text) > 1 Then
txtHue.Text = 1
End If
If CInt(txtLight.Text) < 0 Then
txtLight.Text = 0
End If
End If
End If
End If
End If

On Error GoTo 0
Exit Sub

txtLight_Change_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Sub

Private Sub txtRed_Change()
On Error GoTo txtRed_Change_Error

If frmConverter.ActiveControl = txtRed Then
If Not txtRed.Text = "" Then
If CInt(txtRed.Text) <= 255 And CInt(txtRed.Text) >= 0 Then
Call ChangeColour(False)
Else
If CInt(txtRed.Text) > 255 Then
txtRed.Text = 255
End If
If CInt(txtRed.Text) < 0 Then
txtRed.Text = 0
End If
End If
End If
End If

On Error GoTo 0
Exit Sub

txtRed_Change_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Sub

[appdalesolution]

'---------------------------------------------------------------------------------------
' Procedure : ChangeColour
' DateTime : 11/02/2005 11:15
' Author : lee.dale
' Purpose : Call RGB Convert routines and make changes to UI controls
'---------------------------------------------------------------------------------------

Private Sub ChangeColour(ByVal bHLStoRGB As Boolean)
Dim dRed As Double, dGreen As Double, dBlue As Double
Dim dHue As Double, dLight As Double, dSaturation As Double
Dim vHex As Variant, vColourRef As Variant

On Error GoTo ChangeColour_Error

If bHLStoRGB = True Then
If IsNumeric(txtHue.Text) And _
IsNumeric(txtLight.Text) And _
IsNumeric(txtSaturation.Text) Then
dHue = txtHue.Text
dLight = txtLight.Text
dSaturation = txtSaturation.Text
End If
Call HlsToRgb(dHue, dLight, dSaturation, dRed, dGreen, dBlue)
txtRed.Text = dRed * 255
txtGreen.Text = dGreen * 255
txtBlue.Text = dBlue * 255
Else
If IsNumeric(txtRed.Text) And _
IsNumeric(txtGreen.Text) And _
IsNumeric(txtBlue.Text) Then
dRed = txtRed.Text
dGreen = txtGreen.Text
dBlue = txtBlue.Text
End If
Call RgbToHls(dRed / 255, dGreen / 255, dBlue / 255, dHue, dLight, dSaturation)
txtHue.Text = Format(dHue, "0.00")
txtLight.Text = Format(dLight, "0.00")
txtSaturation.Text = Format(dSaturation, "0.00")
End If
sliRed.Value = txtRed.Text
sliRed.Refresh
sliGreen.Value = txtGreen.Text
sliGreen.Refresh
sliBlue.Value = txtBlue.Text
sliBlue.Refresh
sliHue.Value = txtHue.Text
sliHue.Refresh
sliLight.Value = txtLight.Text * 100
sliLight.Refresh
sliSaturation.Value = txtSaturation * 100
sliSaturation.Refresh
vHex = RGB2HTMLColor(CByte(txtRed.Text), CByte(txtGreen.Text), CByte(txtBlue.Text))
txtHex.Text = vHex
shpRGBColour.BackColor = RGB(txtRed.Text, txtGreen.Text, txtBlue.Text)
txtVBHex.Text = RGBtoVBHex(txtRed.Text, txtGreen.Text, txtBlue.Text)
lblSample.ForeColor = shpRGBColour.BackColor
On Error GoTo 0
Exit Sub

ChangeColour_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Sub

'---------------------------------------------------------------------------------------
' Procedure : SetDefaults
' DateTime : 11/02/2005 11:17
' Author : lee.dale
' Purpose : Set default values of all UI controls
'---------------------------------------------------------------------------------------

Private Sub SetDefaults()
sliRed.Value = txtRed.Text
sliGreen.Value = txtGreen.Text
sliBlue.Value = txtBlue.Text
sliHue.Value = txtHue.Text
sliLight.Value = txtLight.Text
sliSaturation.Value = txtSaturation.Text
End Sub

'---------------------------------------------------------------------------------------
' Procedure : RGB2HTMLColor
' DateTime : 11/02/2005 11:37
' Author : lee dale
' Purpose : Convert RGB Colour to HTML Hex format
'---------------------------------------------------------------------------------------
'
Private Function RGB2HTMLColor(ByVal r As Byte, ByVal g As Byte, _
ByVal b As Byte) As String


Dim HexR, HexB, HexG As Variant
Dim sTemp As String


On Error GoTo RGB2HTMLColor_Error

'R
HexR = Hex(r)
If Len(HexR) < 2 Then HexR = "0" & HexR

'Get Green Hex
HexG = Hex(g)
If Len(HexG) < 2 Then HexG = "0" & HexG

HexB = Hex(b)
If Len(HexB) < 2 Then HexB = "0" & HexB



RGB2HTMLColor = "#" & HexR & HexG & HexB

On Error GoTo 0
Exit Function

RGB2HTMLColor_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Function

[appdalesolution]

'---------------------------------------------------------------------------------------
' Procedure : HlsToRgb
' DateTime : 11/02/2005 11:58
' Author : lee dale
' Purpose : Take HLS values and return corresponding RGB values as ByRef variables
'---------------------------------------------------------------------------------------
'
Private Sub HlsToRgb(ByVal H As Double, ByVal L As Double, _
ByVal S As Double, ByRef r As Double, ByRef g As _
Double, ByRef b As Double)
Dim p1 As Double
Dim p2 As Double

If L <= 0.5 Then
p2 = L * (1 + S)
Else
p2 = L + S - L * S
End If
p1 = 2 * L - p2
If S = 0 Then
r = L
g = L
b = L
Else
r = QqhToRgb(p1, p2, H + 120)
g = QqhToRgb(p1, p2, H)
b = QqhToRgb(p1, p2, H - 120)
End If
End Sub

Private Function QqhToRgb(ByVal q1 As Double, ByVal q2 As _
Double, ByVal hue As Double) As Double
If hue > 360 Then
hue = hue - 360
ElseIf hue < 0 Then
hue = hue + 360
End If
If hue < 60 Then
QqhToRgb = q1 + (q2 - q1) * hue / 60
ElseIf hue < 180 Then
QqhToRgb = q2
ElseIf hue < 240 Then
QqhToRgb = q1 + (q2 - q1) * (240 - hue) / 60
Else
QqhToRgb = q1
End If
End Function

Private Sub txtSaturation_Change()

On Error GoTo txtSaturation_Change_Error

If frmConverter.ActiveControl = txtSaturation Then
If Not txtSaturation = "" Then
If IsNumeric(txtSaturation.Text) Then
If CInt(txtSaturation.Text) <= 1 And CInt(txtSaturation.Text) >= 0 Then
Call ChangeColour(True)
Else
If CInt(txtLight.Text) > 1 Then
txtSaturation.Text = 1
End If
If CInt(txtSaturation.Text) < 0 Then
txtSaturation.Text = 0
End If
End If
End If
End If
End If

On Error GoTo 0
Exit Sub

txtSaturation_Change_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Sub

'---------------------------------------------------------------------------------------
' Procedure : RGBtoVBHex
' DateTime : 11/02/2005 15:48
' Author : lee.dale
' Purpose : Converts supplied RGB values to corresponding vb hex string
'---------------------------------------------------------------------------------------
'
Private Function RGBtoVBHex(ByVal iRed As Integer, ByVal iGreen As Integer, ByVal iBlue As Integer) As String
On Error GoTo RGBtoVBHex_Error

RGBtoVBHex = "&H00" & Hex$(iBlue) & Hex$(iGreen) & Hex$(iRed) & "&"
On Error GoTo 0
Exit Function

RGBtoVBHex_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Function

'---------------------------------------------------------------------------------------
' Procedure : HEXCOL2RGB
' DateTime : 11/02/2005 16:23
' Author : lee.dale
' Purpose :
'---------------------------------------------------------------------------------------
'
Private Function HEXCOL2RGB(ByVal HexColor As String) As String

'The input at this point could be HexColor = "#00FF1F"

Dim Red As String
Dim Green As String
Dim Blue As String
Dim Color As String

On Error GoTo HEXCOL2RGB_Error

Color = Replace(HexColor, "#", "")
'Here HexColor = "00FF1F"

Red = Val("&H" & Mid(Color, 1, 2))
'The red value is now the long version of "00"

Green = Val("&H" & Mid(Color, 3, 2))
'The red value is now the long version of "FF"

Blue = Val("&H" & Mid(Color, 5, 2))
'The red value is now the long version of "1F"


HEXCOL2RGB = CStr(Red) & CStr(Green) & CStr(Blue)
'The output is an RGB value

On Error GoTo 0
Exit Function

HEXCOL2RGB_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select

End Function

Private Sub txtVBHex_Change()
Dim sRGBValue As String

On Error GoTo txtVBHex_Change_Error

If frmConverter.ActiveControl = txtVBHex Then
If Left(txtVBHex, 1) = "&" Then
sRGBValue = VBHextoRGB(txtVBHex)
txtRed.Text = Left(sRGBValue, 3)
txtGreen.Text = Mid(sRGBValue, 4, 3)
txtBlue.Text = Right(sRGBValue, 3)
Call ChangeColour(False)
End If
End If

On Error GoTo 0
Exit Sub

txtVBHex_Change_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Sub

'---------------------------------------------------------------------------------------
' Procedure : VBHextoRGB
' DateTime : 11/02/2005 16:40
' Author : lee.dale
' Purpose : Convert Supplied vb hex value to RGB string
'---------------------------------------------------------------------------------------
'
Private Function VBHextoRGB(ByVal sHexString As String) As String
Dim sColor As String
Dim iRed As Integer, iGreen As Integer, iBlue As Integer

On Error GoTo VBHextoRGB_Error

sColor = Mid(sHexString, 5, 6)
iRed = Val("&H" & Left(sColor, 2))
iGreen = Val("&H" & Mid(sColor, 3, 2))
iBlue = Val("&H" & Right(sColor, 2))
VBHextoRGB = Format(CStr(iRed), "000") & Format(CStr(iGreen), "000") & Format(CStr(iBlue), "000")

On Error GoTo 0
Exit Function

VBHextoRGB_Error:
Select Case Err.Number
Case Else
Call ErrorHandler
End Select
End Function

[DKasler]

Nice work!

This will come in handy.

[Gamemaster1494]

Ummmm, is the website right? Can someone help please? Can you upload the form someone? I got the code, not the form.