'  Внимание: все права защищены!
'  Автор: Павел Сурменок
'  mailto:pavel@vbnet.ru
'  http://vbnet.ru
'  Пример поставляется как есть. Автор не несёт ответственности за
'возможный прямой или косвенный ущерб
'  Вы можете свободно использовать код, содержащийся в примерах в
'собственных приложениях
'  Копирование примера целиком возможно только с письменного согласия
'автора


Option Explicit

Private Type RGBType
    R As Byte
    G As Byte
    B As Byte
End Type

Private Type CMY
    C As Byte
    M As Byte
    Y As Byte
End Type

Private Type CMYK
    C As Byte
    M As Byte
    Y As Byte
    K As Byte
End Type

Private Type YUV
    Y As Byte
    U As Byte
    V As Byte
End Type

Private Type YIQ
    Y As Byte
    I As Byte
    Q As Byte
End Type

Private Type HSL
    H As Byte
    S As Byte
    L As Byte
End Type

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long

Private Function RGBToHex(From As RGBType) As String
Dim Red As String
Dim Green As String
Dim Blue As String

    Red = CStr(Hex$(From.R))
        If Len(Red) = 1 Then
             Red = "0" & Red
        End If
    Green = CStr(Hex$(From.G))
        If Len(Green) = 1 Then
             Green = "0" & Green
        End If
    Blue = CStr(Hex$(From.B))
        If Len(Blue) = 1 Then
             Blue = "0" & Blue
        End If
    RGBToHex = "#" & Red & Green & Blue
End Function

Private Function RGBToHexVB(From As RGBType) As String
Dim Red As String
Dim Green As String
Dim Blue As String

    Red = CStr(Hex$(From.R))
        If Len(Red) = 1 Then
             Red = "0" & Red
        End If
    Green = CStr(Hex$(From.G))
        If Len(Green) = 1 Then
             Green = "0" & Green
        End If
    Blue = CStr(Hex$(From.B))
        If Len(Blue) = 1 Then
             Blue = "0" & Blue
        End If
    RGBToHexVB = "&H" & Blue & Green & Red
End Function

Private Function RGBToDec(From As RGBType) As Long
    RGBToDec = RGB(From.R, From.G, From.B)
End Function

Private Function RGBToCMY(From As RGBType) As CMY
    RGBToCMY.C = 255 - From.R
    RGBToCMY.M = 255 - From.G
    RGBToCMY.Y = 255 - From.B
End Function

Private Function RGBToCMYK(From As RGBType) As CMYK
    RGBToCMYK.C = 255 - From.R
    RGBToCMYK.M = 255 - From.G
    RGBToCMYK.Y = 255 - From.B
    RGBToCMYK.K = MinValue(RGBToCMYK.C, RGBToCMYK.M, RGBToCMYK.Y)
    If RGBToCMYK.K > 0 Then
        RGBToCMYK.C = RGBToCMYK.C - RGBToCMYK.K
        RGBToCMYK.M = RGBToCMYK.M - RGBToCMYK.K
        RGBToCMYK.Y = RGBToCMYK.Y - RGBToCMYK.K
    End If
End Function

Private Function RGBToYUV(From As RGBType) As YUV
    RGBToYUV.Y = CByte(0.299 * From.R + 0.587 * From.G + 0.114 * From.B)
    RGBToYUV.U = CByte((CLng(From.R) - CLng(RGBToYUV.Y)) \ 2 + 128)
    RGBToYUV.V = CByte((CLng(From.B) - CLng(RGBToYUV.Y)) \ 2 + 128)
End Function

Private Function RGBToYIQ(From As RGBType) As YIQ
On Error Resume Next

    RGBToYIQ.Y = CByte(0.299 * From.R + 0.587 * From.G + 0.114 * From.B)
    RGBToYIQ.I = CByte(0.596 * From.R - 0.274 * From.G - 0.322 * From.B)
    RGBToYIQ.Q = CByte(0.212 * From.R - 0.523 * From.G + 0.311 * From.B)
End Function



Private Function HexToRGB(ByVal From As String) As RGBType
    HexToRGB.B = CByte("&H" & Mid$(From, 2, 2))
    HexToRGB.G = CByte("&H" & Mid$(From, 4, 2))
    HexToRGB.R = CByte("&H" & Right$(From, 2))
End Function

Private Function HexVBToRGB(ByVal From As String) As RGBType
    HexToRGB.R = CByte("&H" & Mid$(From, 3, 2))
    HexToRGB.G = CByte("&H" & Mid$(From, 5, 2))
    HexToRGB.B = CByte("&H" & Right$(From, 2))
End Function

Private Function DecToRGB(ByVal From As Long) As RGBType
    ecToRGB.R = From And &HFF
    ecToRGB.G = (From \ &H100) And &HFF
    ecToRGB.B = (From \ &H10000) And &HFF
End Function

Private Function CMYToRGB(From As CMY) As RGBType
    CMYToRGB.R = 255 - From.C
    CMYToRGB.G = 255 - From.M
    CMYToRGB.B = 255 - From.Y
End Function

Private Function CMYKToRGB(From As CMYK) As RGBType
    If From.C + From.K < 255 Then
        CMYKToRGB.R = 255 - (From.C + From.K)
    Else
        CMYKToRGB.R = 0
    End If
    If From.M + From.K < 255 Then
        CMYKToRGB.G = 255 - (From.M + From.K)
    Else
        CMYKToRGB.G = 0
    End If
    If From.Y + From.K < 255 Then
        CMYKToRGB.B = 255 - (From.Y + From.K)
    Else
        CMYKToRGB.B = 0
    End If
End Function

Private Function YUVToRGB(From As YUV) As RGBType
    YUVToRGB.R = From.Y + ((CInt(From.U) * (2 ^ 1) And &HFFFF) - 256)
    YUVToRGB.G = From.Y + ((CInt(From.V) * (2 ^ 1) And &HFFFF) - 256)
    YUVToRGB.B = CByte((From.Y - 0.299 * YUVToRGB.R - 0.114 * YUVToRGB.B) / 0.587)
End Function

Private Function YIQToRGB(From As YIQ) As RGBType
On Error Resume Next

    YIQToRGB.R = CByte(From.Y + 0.956 * From.I + 0.621 * From.Q)
    YIQToRGB.G = CByte(From.Y - 0.272 * From.I - 0.647 * From.Q)
    YIQToRGB.B = CByte(From.Y - 1.105 * From.I + 1.702 * From.Q)
End Function

Private Sub cmdConvert_Click()
Dim RGBClr As RGBType
Dim CMYClr As CMY
Dim CMYKClr As CMYK
Dim YUVClr As YUV
Dim YIQClr As YIQ

    Select Case CLng(Me.Tag)
        Case 0 'Картинка
            RGBClr = DecToRGB(CLng(picColors.Tag))
        Case 1 'RGB
            RGBClr.R = CByte(txtR.Text)
            RGBClr.G = CByte(txtG.Text)
            RGBClr.B = CByte(txtB.Text)
        Case 2 'Hex
            RGBClr = HexToRGB(txtHex.Text)
        Case 3 'HexVB
            RGBClr = DecToRGB(CLng(txtHexVB.Text))
        Case 4 'Dec
            RGBClr = DecToRGB(CLng(txtDec.Text))
        Case 5 'CMY
            CMYClr.C = CByte(txtC.Text)
            CMYClr.M = CByte(txtM.Text)
            CMYClr.Y = CByte(txtY.Text)
            RGBClr = CMYToRGB(CMYClr)
        Case 6 'CMYK
            CMYKClr.C = CByte(txtC2.Text)
            CMYKClr.M = CByte(txtM2.Text)
            CMYKClr.Y = CByte(txtY2.Text)
            CMYKClr.K = CByte(txtK2.Text)
            RGBClr = CMYKToRGB(CMYKClr)
        Case 7 'YUV
            YUVClr.Y = CByte(txtY3.Text)
            YUVClr.U = CByte(txtU3.Text)
            YUVClr.V = CByte(txtV3.Text)
            RGBClr = YUVToRGB(YUVClr)
        Case 8 'YUV
            YIQClr.Y = CByte(txtY4.Text)
            YIQClr.I = CByte(txtI4.Text)
            YIQClr.Q = CByte(txtQ4.Text)
            RGBClr = YIQToRGB(YIQClr)
    End Select
    picColors.Cls
    txtR.Text = CStr(RGBClr.R)
    txtG.Text = CStr(RGBClr.G)
    txtB.Text = CStr(RGBClr.B)
    
    txtHex.Text = RGBToHex(RGBClr)
    
    txtHexVB.Text = RGBToHexVB(RGBClr)
    
    txtDec.Text = RGBToDec(RGBClr)
    
    CMYClr = RGBToCMY(RGBClr)
    txtC.Text = CStr(CMYClr.C)
    txtM.Text = CStr(CMYClr.M)
    txtY.Text = CStr(CMYClr.Y)
    
    CMYKClr = RGBToCMYK(RGBClr)
    txtC2.Text = CStr(CMYKClr.C)
    txtM2.Text = CStr(CMYKClr.M)
    txtY2.Text = CStr(CMYKClr.Y)
    txtK2.Text = CStr(CMYKClr.K)

    YUVClr = RGBToYUV(RGBClr)
    txtY3.Text = CStr(YUVClr.Y)
    txtU3.Text = CStr(YUVClr.U)
    txtV3.Text = CStr(YUVClr.V)

    YIQClr = RGBToYIQ(RGBClr)
    txtY4.Text = CStr(YIQClr.Y)
    txtI4.Text = CStr(YIQClr.I)
    txtQ4.Text = CStr(YIQClr.Q)

End Sub

Private Sub Form_Load()
Me.Tag = "0"
End Sub

Private Sub optFrom_Click(Index As Integer)
Me.Tag = CStr(Index)
End Sub

Private Sub picColors_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
picColors.Cls
picColors.Tag = CStr(GetPixel(picColors.hdc, x / Screen.TwipsPerPixelX, Y / Screen.TwipsPerPixelY))
picColors.Line (x - 100, Y)-(x + 100, Y), vbWhite
picColors.Line (x, Y - 100)-(x, Y + 100), vbWhite
End Sub

Private Function MaxValue(ByVal Val1 As Byte, ByVal Val2 As Byte, ByVal Val3 As Byte) As Byte
    If Val1 > Val2 Then MaxValue = Val1 Else MaxValue = Val2
    If Val3 > MaxValue Then MaxValue = Val3
End Function

Private Function MinValue(ByVal Val1 As Byte, ByVal Val2 As Byte, ByVal Val3 As Byte) As Byte
    If Val1 < Val2 Then MinValue = Val1 Else MinValue = Val2
    If Val3 < MinValue Then MinValue = Val3
End Function

Копирование примера целиком возможно только с письменного согласия
автора