网页功能: 加入收藏 设为首页 网站搜索  
颜色转换函数(RGB、HSB、CMYK、Lab)
发表日期:2003-12-09作者:enmity | 灵感之源[] 出处:  

Option Explicit

Private R As Byte

Private G As Byte

Private B As Byte

Public Property Get cmyC() As Byte

  cmyC = 255 - R

End Property

Public Property Get cmyM() As Byte

  cmyM = 255 - G

End Property

Public Property Get cmykK() As Integer

  cmykK = Minimum(255 - R, 255 - G, 255 - B) / 2.55

End Property

Public Property Get cmykC() As Integer

  Dim MyR As Integer, Div As Integer

  MyR = R / 2.55

  

  Div = (100 - cmykK)

  If Div = 0 Then Div = 1

  

  cmykC = ((100 - MyR - cmykK) / Div) * 100

End Property

Public Property Get cmykM() As Integer

  Dim MyG As Integer, Div As Integer

  MyG = G / 2.55

  

  Div = (100 - cmykK)

  If Div = 0 Then Div = 1

  

  cmykM = ((100 - MyG - cmykK) / Div) * 100

End Property

Public Property Get cmykY() As Integer

  Dim MyB As Integer, Div As Integer

  MyB = B / 2.55

  

  Div = (100 - cmykK)

  If Div = 0 Then Div = 1

  

  cmykY = ((100 - MyB - cmykK) / Div) * 100

End Property

Public Property Get cmyY() As Byte

  cmyY = 255 - B

End Property

Public Property Get hlsH() As Integer

  Dim MyR As Single, MyG As Single, MyB As Single

  Dim Max As Single, Min As Single

  Dim Delta As Single, MyVal As Single

  

  MyR = R / 255: MyG = G / 255: MyB = B / 255

  

  Max = Maximum(MyR, MyG, MyB)

  Min = Minimum(MyR, MyG, MyB)

  

  If Max <> Min Then

    Delta = Max - Min

    Select Case Max

      Case MyR

        MyVal = (MyG - MyB) / Delta

      Case MyG

        MyVal = 2 + (MyB - MyR) / Delta

      Case MyB

        MyVal = 4 + (MyR - MyG) / Delta

    End Select

  End If

  

  MyVal = (MyVal + 1) * 60

  If MyVal < 0 Then MyVal = MyVal + 360

  

  hlsH = MyVal

  Debug.Print hlsH

End Property

Public Property Get hlsL() As Integer

  hlsL = ((Maximum(R, G, B) + Minimum(R, G, B)) / 2) / 2.55

End Property

Public Property Get hlsS() As Integer

  Dim MyR As Single, MyG As Single, MyB As Single

  Dim Max As Single, Min As Single, MyS As Single

  

  MyR = R / 255: MyG = G / 255: MyB = B / 255

  

  Max = Maximum(MyR, MyG, MyB)

  Min = Minimum(MyR, MyG, MyB)

  

  If Max <> Min Then

    If hlsL <= 50 Then

      MyS = (Max - Min) / (Max + Min)

    Else

      MyS = (Max - Min) / (2 - Max - Min)

    End If

    hlsS = MyS * 100

  End If

End Property

Private Function Minimum(ParamArray Vals())

  Dim n As Integer, MinVal

  

  MinVal = Vals(0)

  

  For n = 0 To UBound(Vals)

    If Vals(n) < MinVal Then MinVal = Vals(n)

  Next n

  Minimum = MinVal

End Function

Private Function Maximum(ParamArray Vals())

  Dim n As Integer, MaxVal

  

  For n = 0 To UBound(Vals)

    If Vals(n) > MaxVal Then MaxVal = Vals(n)

  Next n

  Maximum = MaxVal

End Function

Public Property Let rgbR(NewVal As Byte)

  R = NewVal

End Property

Public Property Get rgbR() As Byte

  rgbR = R

End Property

Public Property Get rgbG() As Byte

  rgbG = G

End Property

Public Property Get rgbB() As Byte

  rgbB = B

End Property

Public Property Get ycbcrY() As Byte

  ycbcrY = R * 0.2989 + G * 0.5866 + B * 0.1145

End Property

Public Property Get ycbcrCb() As Byte

  Dim MyCb As Integer

  MyCb = -0.1687 * R - 0.3313 * G + 0.5 * B + 128

  

  ycbcrCb = IIf(MyCb <= 255, MyCb, 255)

End Property

Public Property Get ycbcrCr() As Byte

  Dim MyCr As Integer

  MyCr = 0.5 * R - 0.4187 * G - 0.0813 * B + 128

  

  ycbcrCr = IIf(MyCr <= 255, MyCr, 255)

End Property

Public Property Let rgbG(NewVal As Byte)

  G = NewVal

End Property

Public Property Let rgbB(NewVal As Byte)

  B = NewVal

End Property

Public Sub SetCMY(C As Integer, M As Integer, Y As Integer)

  R = 255 - C

  G = 255 - M

  B = 255 - Y

End Sub

Public Sub SetHLS(H As Integer, L As Integer, S As Integer)

  Dim MyR As Single, MyG As Single, MyB As Single

  Dim MyH As Single, MyL As Single, MyS As Single

  Dim Min As Single, Max As Single, Delta As Single

  

  MyH = (H / 60) - 1: MyL = L / 100: MyS = S / 100

  If MyS = 0 Then

    MyR = MyL: MyG = MyL: MyB = MyL

  Else

    If MyL <= 0.5 Then

      Min = MyL * (1 - MyS)

    Else

      Min = MyL - MyS * (1 - MyL)

    End If

    Max = 2 * MyL - Min

    Delta = Max - Min

    

    Select Case MyH

      Case Is < 1

        MyR = Max

        If MyH < 0 Then

          MyG = Min

          MyB = MyG - MyH * Delta

        Else

          MyB = Min

          MyG = MyH * Delta + MyB

        End If

      Case Is < 3

        MyG = Max

        If MyH < 2 Then

          MyB = Min

          MyR = MyB - (MyH - 2) * Delta

        Else

          MyR = Min

          MyB = (MyH - 2) * Delta + MyR

        End If

      Case Else

        MyB = Max

        If MyH < 4 Then

          MyR = Min

          MyG = MyR - (MyH - 4) * Delta

        Else

          MyG = Min

          MyR = (MyH - 4) * Delta + MyG

        End If

    End Select

  End If

  

  R = MyR * 255: G = MyG * 255: B = MyB * 255

End Sub

Public Sub SetCMYK(C As Integer, M As Integer, Y As Integer, K As Integer)

  Dim MyC As Single, MyM As Single, MyY As Single, MyK As Single

  

  MyC = C / 100: MyM = M / 100: MyY = Y / 100: MyK = K / 100

  

  R = (1 - (MyC * (1 - MyK) + MyK)) * 255

  G = (1 - (MyM * (1 - MyK) + MyK)) * 255

  B = (1 - (MyY * (1 - MyK) + MyK)) * 255

End Sub

Public Sub SetYCbCr(Y As Integer, Cb As Integer, Cr As Integer)

  Dim MyR As Integer, MyG As Integer, MyB As Integer

  

  MyR = Y + 1.402 * (Cr - 128)

  MyG = Y - 0.34414 * (Cb - 128) - 0.71414 * (Cr - 128)

  MyB = Y + 1.772 * (Cb - 128)

  

  If MyR > 255 Then MyR = 255

  If MyG > 255 Then MyG = 255

  If MyB > 255 Then MyB = 255

  

  If MyR < 0 Then MyR = 0

  If MyG < 0 Then MyG = 0

  If MyB < 0 Then MyB = 0

  R = MyR

  G = MyG

  B = MyB

End Sub

我来说两句】 【加入收藏】 【返加顶部】 【打印本页】 【关闭窗口
中搜索 颜色转换函数(RGB、HSB、CMYK、Lab)
本类热点文章
  颜色转换函数(RGB、HSB、CMYK、Lab)
  MCI命令详解
  不装RealPlayer播放RM文件
  在VB中显示动画鼠标图标
  在VB6.0中播放GIF动画
  用VB实现队列播放MP3
  怎样检查声卡的存在
  怎样在VB中播放Flash动画
  制作自己的MP3播放器
  在我们的程序中让电脑说英语
  基于VB算法+Picture+Timer控件制作的39..
  在VB中用API实现多媒体
最新分类信息我要发布 
最新招聘信息

关于我们 / 合作推广 / 给我留言 / 版权举报 / 意见建议 / 广告投放  
Copyright ©2003-2019 Lihuasoft.net webmaster(at)lihuasoft.net
网站编程QQ群   京ICP备05001064号 页面生成时间:0.00404