VB Colour Converter-VBForums
Results 1 to 8 of 8

Thread: VB Colour Converter

Hybrid View

  1. #1

    Thread Starter
    Member appdalesolution's Avatar
    Join Date
    Nov 2004
    Location
    London
    Posts
    37

    VB Colour Converter

    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!
    Last edited by appdalesolution; Mar 13th, 2005 at 04:30 AM.
    Lee Dale
    http://www.appdalesolutions.co.uk
    Web Design, Database/Software Developement, Hardware Upgrades, Network design/maintenance.

  2. #2
    Hyperactive Member DarkX_Greece's Avatar
    Join Date
    Jan 2004
    Location
    Athens (Greece)
    Posts
    315

    Re: VB Colour Converter

    Very nice appdalesolution!
    Short CV:
    1. Visual Basic 6 Programmer
    2. Web Expert


    Botonakis Web Services

  3. #3

    Thread Starter
    Member appdalesolution's Avatar
    Join Date
    Nov 2004
    Location
    London
    Posts
    37

    Re: VB Colour Converter

    Thanks glad you liked it!

    i have been infomed that there is an error with the installer which i have fixed now.
    Last edited by appdalesolution; Mar 13th, 2005 at 04:28 AM.
    Lee Dale
    http://www.appdalesolutions.co.uk
    Web Design, Database/Software Developement, Hardware Upgrades, Network design/maintenance.

  4. #4

    Thread Starter
    Member appdalesolution's Avatar
    Join Date
    Nov 2004
    Location
    London
    Posts
    37

    Re: VB Colour Converter

    heres the code for the app:

    frmConverter:
    Code:
    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
    Lee Dale
    http://www.appdalesolutions.co.uk
    Web Design, Database/Software Developement, Hardware Upgrades, Network design/maintenance.

  5. #5

    Thread Starter
    Member appdalesolution's Avatar
    Join Date
    Nov 2004
    Location
    London
    Posts
    37

    Re: VB Colour Converter

    Code:
    '---------------------------------------------------------------------------------------
    ' 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
    Lee Dale
    http://www.appdalesolutions.co.uk
    Web Design, Database/Software Developement, Hardware Upgrades, Network design/maintenance.

  6. #6

    Thread Starter
    Member appdalesolution's Avatar
    Join Date
    Nov 2004
    Location
    London
    Posts
    37

    Re: VB Colour Converter

    Code:
    '---------------------------------------------------------------------------------------
    ' 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
    Lee Dale
    http://www.appdalesolutions.co.uk
    Web Design, Database/Software Developement, Hardware Upgrades, Network design/maintenance.

  7. #7
    Fanatic Member
    Join Date
    Oct 2009
    Location
    Missouri
    Posts
    770

    Re: VB Colour Converter

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.