VBA クラスモジュールを使って色見本(カラーパレット)を作る

前回の記事ではVBAで2つの画像を比較して内容が同一かどうかを判定した。
「次回はこれを更に自動である程度分類するため、VBAで機械学習もどきをやってみようと思う。」と書いたのだが、ちょっとコード分量が多くなりそうなので前半と後半に分けようと思う。

その前半が今回。
それがなんで色見本なんてタイトルになってるかというと、記事単体で検索されたときの利便性を考慮した結果である。

今回は画像をピクセル単位で比較することになるのでまずはピクセルを簡単に比較できるように、色をオブジェクトとして扱うことにした。

ただクラスモジュールだけ紹介して「はいおしまい」ではあんまりなので、そのクラスの使い方のサンプルとしてカラーパレットを作ってみたという話。

まずクラスモジュールを挿入し、オブジェクト名をColorObjectとしておく。

Option Explicit
Private Declare Sub ColorRGBToHLS Lib "Shlwapi.dll" _
    (ByVal clrRGB As Long, _
    pwHue As Integer, _
    pwLuminance As Integer, _
    pwSaturation As Integer)
Private Declare Function ColorHLSToRGB Lib "Shlwapi.dll" _
    (ByVal wHue As Integer, _
    ByVal wLuminance As Integer, _
    ByVal wSaturation As Integer) As Long

Private colorRGB As Long
Private hue_ As Integer
Private luminance_ As Integer
Private saturation_ As Integer

Property Get Hue() As Long
    Hue = hue_
End Property
Property Get Luminance() As Long
    Luminance = luminance_
End Property
Property Get RGBValue() As Long
    RGBValue = colorRGB
End Property

Property Get Saturation() As Long
    Saturation = saturation_
End Property

Property Get Red() As Long
    Red = colorRGB \ 256 ^ 0 Mod 256
End Property
Property Get Green() As Long
    Green = colorRGB \ 256 ^ 1 Mod 256
End Property
Property Get Blue() As Long
    Blue = colorRGB \ 256 ^ 2 Mod 256
End Property

Property Let RGBValue(rgb_value As Long)
    If rgb_value >= vbBlack And rgb_value <= vbWhite Then
        colorRGB = rgb_value
        Call ColorRGBToHLS(colorRGB, hue_, luminance_, saturation_)
    Else
        Err.Raise vbObjectError, , "不正なRGB値が渡されました。"
    End If
End Property
Function SetColorByHLS(h, l, s)
    Me.RGBValue = ColorHLSToRGB(h, l, s)
    SetColorByHLS = colorRGB
End Function

ColorRGBToHLSについては以下の記事で紹介した。
thom.hateblo.jp

今回カラーパレット作成にあたって使うのはこの逆関数ColorHLSToRGBである。

クラスは汎用的に色を扱えるように設計したので今回のサンプルで使用しないプロパティ・メソッドが殆どだけど次回必要になるので書いておくべし。

さて、このColorObjectクラスを使ってカラーパレットを作ってみよう。

実は以前もトライしたことがあったんだけど、当時はColorHLSToRGB関数の存在を知らなかったのでRGBそれぞれに割り振る値を遷移させることでそれっぽい色相を実現していた。
thom.hateblo.jp

ColorHLSToRGBを使えばはるかに簡単。

今回は面倒なのでフォームではなくてシート上に作成する。
Sheet1モジュールに以下を挿入して実行してみよう。

Sub カラーパレット()
    Const SATURATION_VALUE = 240
    Dim i, j
    For i = 0 To 24: For j = 0 To 24
        With New ColorObject
            .SetColorByHLS i * 10, j * 10, SATURATION_VALUE
            Cells(i + 1, j + 1).Interior.Color = .RGBValue
        End With
    Next j, i
    Range(Cells(1, 1), Cells(25, 25)).Borders.LineStyle = xlContinuous
End Sub

結果はこのとおり。

※セル幅・ズームは手でいじってます。

でもなんか普段みるやつと違う。

↓普段みるやつ

こうか？

Sub カラーパレット2()
    Const SATURATION_VALUE = 240
    Dim i, j
    For i = 0 To 24: For j = 0 To 24
        With New ColorObject
            .SetColorByHLS i * 10, j * 10, SATURATION_VALUE
            Cells(25 - j, 25 - i).Interior.Color = .RGBValue
        End With
    Next j, i
    Range(Cells(1, 1), Cells(25, 25)).Borders.LineStyle = xlContinuous
End Sub

惜しい。
もう一度普段みるパレットをよく確認してみると、どうやらメイン領域で色相・彩度を扱っていて、隣のバーで明度を扱ってるようだ。

ちなみに定数をSATURATION_VALUEなんて長ったらしい名前にしたのは、SATURATIONとするとこれに引っ張られてクラスモジュール側に設定したSaturationプロパティまで大文字になってしまうためだ。このあたりの余計なお節介、イケてない。

さて、ふたたび。

これでどうだ。

Sub カラーパレット3()
    Const LUMINANCE_VALUE = 120
    Dim i, j
    For i = 0 To 24: For j = 0 To 24
        With New ColorObject
            .SetColorByHLS i * 10, LUMINANCE_VALUE, j * 10
            Cells(25 - j, 25 - i).Interior.Color = .RGBValue
        End With
    Next j, i
    Range(Cells(1, 1), Cells(25, 25)).Borders.LineStyle = xlContinuous
End Sub

おおっ！

ん？

なにこれｗｗｗ

気になるけど無視して24段に減らそう。

Sub カラーパレット4()
    Const LUMINANCE_VALUE = 120
    Dim i, j
    For i = 0 To 24: For j = 1 To 24    'jを1スタートに変更
        With New ColorObject
            .SetColorByHLS i * 10, LUMINANCE_VALUE, j * 10
            Cells(25 - j, 25 - i).Interior.Color = .RGBValue
        End With
    Next j, i
    
    '罫線範囲を変更
    Range(Cells(1, 1), Cells(24, 25)).Borders.LineStyle = xlContinuous
End Sub

完成！！

はい、今回はここまで。