前回
HSLとRGBの相互変換を使って色の作成
もう少し何とかしたい
上からR,G,BとH,S,L
スライダーを動かすか左にあるテキストボックスに数値を入力すると
アクティブセルの背景色が変わる
いつもの午後のパレットと同じアドインにしたのでアドインを導入すると
こんな並びになっている右端のアイコンをクリックで起動
参照したところ
RGBとHSLの相互変換ツールと変換計算式 - PEKO STEP
ここがわかりやすかった
RGB色空間とHLS(HSL, HSI)色空間の相互変換 Javascript版 - 今日も適当ダイアリー
Office TANAKA - VBAの変数[ユーザー定義型]
VBの構造体みたいなの
ダウンロード
アドインファイル名：午後のパレット_20150510.xlam
午後のパレット_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日後
