エクセル2007アドイン、その24、RGBとHSLでも色作成

前回

gogowaten.hatenablog.com

 

 

HSLとRGBの相互変換を使って色の作成

http://www.geocities.jp/gogowaten/excel_animation07.gif

もう少し何とかしたい

 

上からR,G,BとH,S,L

スライダーを動かすか左にあるテキストボックスに数値を入力すると

アクティブセルの背景色が変わる

いつもの午後のパレットと同じアドインにしたのでアドインを導入すると

こんな並びになっている右端のアイコンをクリックで起動

 

 

参照したところ

RGBとHSLの相互変換ツールと変換計算式 - PEKO STEP

http://www.peko-step.com/tool/hslrgb.html#ppick1

ここがわかりやすかった

 

RGB色空間とHLS(HSL, HSI)色空間の相互変換 Javascript版 - 今日も適当ダイアリー

http://d.hatena.ne.jp/ja9/20100907/1283840213

 

Office TANAKA - VBAの変数[ユーザー定義型]

http://officetanaka.net/excel/vba/variable/12.htm

VBの構造体みたいなの

 

ダウンロード

アドインファイル名：午後のパレット_20150510.xlam

OneDrive 午後のパレット_20150510.xlam

エクセル2007アドイン - OneDrive

午後のパレット_20150510.xlam(ヤフーボックス)

 

 

ソースファイル

ファイル名：午後のパレット_20150510.xlsm

ここからメモ(いろいろ間違っていたので2015年5月15日書き換えた)

'Office TANAKA - VBAの変数[ユーザー定義型]
'http://officetanaka.net/excel/vba/variable/12.htm
'VBの構造体みたいなの
Public Type myRGB
    iRed As Integer
    iGreen As Integer
    iBlue As Integer
End Type

Public Type myHSL
    H As Double 'Singleだと足りないDoubleで！
    S As Double
    L As Double
End Type
'Public Enum GrayScaleType
'    HDTV = 0
'    NTSC = 1
'End Enum

Function rColorGet(ByVal col As Long) As Long 'Long値のColorを受け取ってRGBのRを返す
    Dim r As Long
    r = col Mod 256
    rColorGet = r
End Function
Function gColorGet(ByVal col As Long) As Long 'Long値のColorを受け取ってRGBのGを返す
    Dim g As Long
    g = Int(col / 256) Mod 256
    gColorGet = g
End Function
Function bColorGet(ByVal col As Long) As Long 'Long値のColorを受け取ってRGBのBを返す
    Dim b As Long
    b = Int(col / 256 / 256)
    bColorGet = b
End Function

Function HSL2RGB色相をRGBに変換(ByVal H, ByVal S, ByVal L) As myRGB 'H,S,Lは正規化
'RGBとHSLの相互変換ツールと変換計算式 - PEKO STEP
'http://www.peko-step.com/tool/hslrgb.html#ppick3
    Dim iMax, iMin As Double
    Dim r, g, b As Double
    If L < 0.5 Then
        iMax = 255 * (L + L * S)
        iMin = 255 * (L - L * S)
    Else
        iMax = 255 * (L + (1 - L) * S)
        iMin = 255 * (L - (1 - L) * S)
    End If
    
    H = H * 360
    Select Case True
        Case 0 <= H And H < 60
            r = iMax
            g = (H / 60) * (iMax - iMin) + iMin
            b = iMin
        Case 60 <= H And H < 120
            r = ((120 - H) / 60) * (iMax - iMin) + iMin
            g = iMax
            b = iMin
        Case 120 <= H And H < 180
            r = iMin
            g = iMax
            b = ((H - 120) / 60) * (iMax - iMin) + iMin
        Case 180 <= H And H < 240
            r = iMin
            g = ((240 - H) / 60) * (iMax - iMin) + iMin
            b = iMax
        Case 240 <= H And H < 300
            r = ((H - 240) / 60) * (iMax - iMin) + iMin
            g = iMin
            b = iMax
       ' Case 300 <= H And H < 360
        Case 300 <= H And H <= 360
            r = iMax
            g = iMin
            b = ((360 - H) / 60) * (iMax - iMin) + iMin
    End Select
    r = CInt(r)
    g = CInt(g)
    b = CInt(b)
    Dim oreRGB As myRGB
    oreRGB.iRed = r
    oreRGB.iGreen = g
    oreRGB.iBlue = b
    HSL2RGB色相をRGBに変換 = oreRGB
    
End Function
Function Color2HSL(myColor) As myHSL
'受け取る値はColor(long値)
'Hは0から360の間の数値、SとLは0-1の間の数値で返す
    Dim r, g, b
    Dim c
    c = myColor ' ActiveCell.Interior.Color
    r = rColorGet(c)
    g = gColorGet(c)
    b = bColorGet(c)
    
    Dim iMax, iMin
    iMax = WorksheetFunction.max(r, g, b)
    iMin = WorksheetFunction.min(r, g, b)
    
    'RGBの最小値と最大値が同じなら0を返して終わり
    Dim H, S, L
    
    If iMax = iMin Then
       H = 0
    ElseIf iMax = r Then
       H = 60 * (g - b) / (iMax - iMin)
    ElseIf iMax = g Then
       H = 60 * (b - r) / (iMax - iMin) + 120
    Else
       H = 60 * (r - g) / (iMax - iMin) + 240
    End If
    
    'マイナスの値なら360を足す
    If H < 0 Then
        H = H + 360
    End If
    
    '彩度
    If iMax = iMin Then
        S = 0
    ElseIf (iMax + iMin) / 2 <= 127 Then
        S = (iMax - iMin) / (iMax + iMin)
    Else
        S = (iMax - iMin) / (510 - iMax - iMin)
    End If
    
    '輝度
    L = (iMax + iMin) / 2
    
    Dim hsl As myHSL
    'hsl.H = H
    hsl.H = H / 360
    hsl.S = S
    hsl.L = L / 255
    
    Color2HSL = hsl

End Function
Function RGB2HSL(ByVal r, ByVal g, ByVal b) As myHSL
'受け取る値は0－255の間の整数値
'Hは0から360の間の数値、SとLは0-1の間の数値で返す
    Dim iMax, iMin
    iMax = WorksheetFunction.max(r, g, b)
    iMin = WorksheetFunction.min(r, g, b)
    
    'RGBの最小値と最大値が同じなら0を返して終わり
    Dim H, S, L
    
    If iMax = iMin Then
       H = 0
    ElseIf iMax = r Then
       H = 60 * (g - b) / (iMax - iMin)
    ElseIf iMax = g Then
       H = 60 * (b - r) / (iMax - iMin) + 120
    Else
       H = 60 * (r - g) / (iMax - iMin) + 240
    End If
    
    'マイナスの値なら360を足す
    If H < 0 Then
        H = H + 360
    End If
    
    '彩度
    If iMax = iMin Then
        S = 0
    ElseIf (iMax + iMin) / 2 <= 127 Then
        S = (iMax - iMin) / (iMax + iMin)
    Else
        S = (iMax - iMin) / (510 - iMax - iMin)
    End If
    
    '輝度
    L = (iMax + iMin) / 2
    
    Dim hsl As myHSL
    'hsl.H = H '0-360で返す
    hsl.H = H / 360 '0-1で返す
    hsl.S = S
    hsl.L = L / 255
    
    RGB2HSL = hsl
   
End Function

Function NTSCグレースケール(ByVal r, ByVal g, ByVal b)
    Dim rr, gg, bb As Double
    rr = 0.298912
    gg = 0.586611
    bb = 0.114478
    Dim Y
    Y = (rr * r) + (gg * g) + (bb * b)
    NTSCグレースケール = Y
End Function
Function HDTVグレースケール(ByVal r, ByVal g, ByVal b)
    Dim rr, gg, bb, X As Double
    rr = 0.222015
    gg = 0.706655
    bb = 0.07133
    X = 2.2
    
    r = (r ^ X) * rr
    g = (g ^ X) * gg
    b = (b ^ X) * bb
    Dim Y
    Y = (r + g + b) ^ (1 / X)
    HDTVグレースケール = Y
End Function
Function NTSCグレースケール2(ByVal r, ByVal g, ByVal b)
'係数をHDTVのものにしてみた
    Dim rr, gg, bb As Double
    rr = 0.222015
    gg = 0.706655
    bb = 0.07133
    Dim Y
    Y = (rr * r) + (gg * g) + (bb * b)
    NTSCグレースケール2 = Y
End Function
Function NTSCグレースケール3(ByVal r, ByVal g, ByVal b)
'係数をオリジナルにしてみた結果、いまいち
    Dim rr, gg, bb As Double
    rr = 0.1
    gg = 0.85
    bb = 0.05
    Dim Y
    Y = (rr * r) + (gg * g) + (bb * b)
    NTSCグレースケール3 = Y
End Function

Function HSLのL変化でY輝度(ByVal H, ByVal S, ByVal L) As myRGB '引数は全て正規化、Lは開始値
    'HSLからRGBを求めてから、Y輝度を求める
    Dim i As Integer
    Dim kijun
    kijun = CInt(L * 255)
    For i = L To 255
        iRGB = HSL2RGB色相をRGBに変換(H, S, i / 255)
    Next
End Function

Function LOnlyChangeLだけ変更グレースケール版( _
    ByVal H, ByVal S, ByVal LStart, Frequency, myStart, myEnd, CRange As ChangeRange, gType As String) As myRGB()
'HSLのLを開始値から1個づつ上げていって、その時のグレースケールにした時の輝度Yを調べる
'Y一定の値に達していたらその時のRGB値を配列に入れていく
   'H , S, LStartは正規化した数値、myStartとmyEndは0-255で
'   LStart 'L開始値
'    Frequency = 10 'Y輝度分割数
'    myStart = 100 'Y輝度開始値
'    myEnd = 255 'Y輝度終了値
'    CRange '上方、下方、全体
    LStart = LStart * 255
    Dim Y 'グレースケールの輝度
    Dim ikko '次の目標値に加算する、一回あたりの加算値
    Dim iStart, iEnd, iStep
    If CRange = All Then
        ikko = 255 / Frequency
        iStart = 0
        iStep = 1
        iEnd = 255
    ElseIf CRange = UP Then
        ikko = (255 - myStart) / (Frequency + 1)
        iStart = LStart
        iStep = 1
        iEnd = 255
    ElseIf CRange = DOWN Then
        ikko = myStart / (Frequency + 1)
        iStart = LStart
        iStep = -1
        iEnd = 0
    End If
    'ikko = (myEnd - myStart) / Frequency
    Dim cnt, i As Integer
    cnt = 0 'カウント
    Dim iRGB As myRGB
    Dim RGBs() As myRGB
    
    
    
    For i = iStart To iEnd Step iStep
        iRGB = HSL2RGB色相をRGBに変換(H, S, i / 255)
        
        Select Case gType ' UserForm色作成.ComboBoxGrayScale.Value
            Case "HDTV"
                Y = HDTVグレースケール(iRGB.iRed, iRGB.iGreen, iRGB.iBlue)
            Case "NTSC"
                Y = NTSCグレースケール(iRGB.iRed, iRGB.iGreen, iRGB.iBlue)
            Case "NTSC2"
                Y = NTSCグレースケール2(iRGB.iRed, iRGB.iGreen, iRGB.iBlue)
            Case "NTSC3"
                Y = NTSCグレースケール3(iRGB.iRed, iRGB.iGreen, iRGB.iBlue)
        End Select
        
        If CRange = DOWN Then
            If Y <= myStart - (ikko * (cnt + 1)) Then
                ReDim Preserve RGBs(cnt)
                RGBs(cnt) = iRGB
                cnt = cnt + 1
            End If
        ElseIf CRange = UP Then
            
            If Y >= ikko * (cnt + 1) + myStart Then
                ReDim Preserve RGBs(cnt)
                RGBs(cnt) = iRGB
                cnt = cnt + 1
            End If
        Else
            If Y >= ikko * (cnt + 0) Then
                ReDim Preserve RGBs(cnt)
                RGBs(cnt) = iRGB
                cnt = cnt + 1
            End If
        End If
    Next
    LOnlyChangeLだけ変更グレースケール版 = RGBs
End Function


 'Colorを今の表示のグレースケール形式に変換した時の輝度Yを返す
Public Function Color2GrayScale(myColor, gType As String) As Double
    Dim Y
    Dim r, g, b As Integer
    r = rColorGet(myColor)
    g = gColorGet(myColor)
    b = bColorGet(myColor)
    Y = RGB2GrayScale(r, g, b, gType)
    Color2GrayScale = Y
End Function

'RGBを今の表示のグレースケール形式に変換した時の輝度Yを返す
Public Function RGB2GrayScale(r, g, b, gType As String) As Double
    Dim Y
    Select Case gType ' Me.ComboBoxGrayScale.Text
        Case "HDTV"
            Y = HDTVグレースケール(r, g, b)
        Case "NTSC"
            Y = NTSCグレースケール(r, g, b)
        Case "NTSC2"
            Y = NTSCグレースケール2(r, g, b)
        Case "NTSC3"
            Y = NTSCグレースケール3(r, g, b)
    End Select
    RGB2GrayScale = Y
End Function

 

 

続きは2日後

gogowaten.hatenablog.com