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/soft...rconverter.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.