VBA GDI32で画像をピクセルごとに比較して類似画像を選り分けるマクロ

今回の記事は以下3記事の集大成である。
1) VBA アドイン作成で使用するリボンアイコンの組み込み画像(ImageMSO)をBitmapで一括保存する方法 - t-hom’s diary
2) VBAで2つの画像ファイルを比較して内容が同一かどうかを判定する方法 - t-hom’s diary
3) VBA クラスモジュールを使って色見本(カラーパレット)を作る - t-hom’s diary

実用性の面で上手くいかないところがあり、まだ試行錯誤の途中なのだが一旦骨格はできたので公開することにした。

作成に当たってはこちらのサイトを参考にさせていただいた。感謝！
画像からGetPixelでピクセル情報を取得し、セルの色を変更（Excel VBA） - Bird-Soft Weblog

考え方

まず基準になるアイコン画像を選ぶ。今回はファイルアイコンを抽出したいので、適当にファイルの形状のアイコンをひとつ選んだ。

こちらのCustomFooterGallery.bmpである。

次に、もう一つファイル型のアイコンを選ぶ。

今回はCustomPageNumberBottomGallery.bmpをチョイスした。

この2つのそれぞれのピクセルを取得し、輝度と色相が似通った箇所だけ抜き出すと、このようになる。

※細かい話をすると実際にはこんな感じになるのだけど、ややこしいので のっぺらぼうになることにして話を進める。

すると、この のっぺらぼうが、類似ファイルを探す際のフィルターになる。

あとは各ファイルをループで回しながらフィルターと同じ箇所のピクセルを比較し、一致率が一定以上のものを類似画像と判定すればよい。

注意点は、白に近いほど輝度の高いピクセルは無視すること。
でないと余白も比較対処に入ってしまい、大量の類似画像がでてくる。

作り方

ColorObjectクラス

まず前回の記事で作ったColorObjectを利用する。
クラスモジュールを挿入し、オブジェクト名を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

BitmapObjectクラス

次にビットマップをオブジェクトとして扱うため、BitmapObjectも作成する。
クラスモジュールを挿入し、オブジェクト名をBitmapObjectとして以下を貼り付ける。

Private Const IMAGE_BITMAP As Long = 0
Private Const LR_LOADFROMFILE As Long = &H10
Private Declare Function CreateCompatibleDC _
    Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC _
    Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject _
    Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject _
    Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function LoadImage _
    Lib "user32" Alias "LoadImageA" ( _
    ByVal hInst As Long, ByVal lpsz As String, _
    ByVal un1 As Long, ByVal n1 As Long, _
    ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function GetPixel _
    Lib "gdi32" (ByVal hDC As Long, _
    ByVal x As Long, ByVal y As Long) As Long
Public FilePath As String
Public ToString As String
Private colorArray() As Long
Private mask() As Boolean

Public Property Get Pixel(x, y) As ColorObject
    Dim ret As New ColorObject
    ret.RGBValue = colorArray(x, y)
    Set Pixel = ret
End Property

Function EvalSimilarityScore(target As BitmapObject) As Long
    Dim hit As Long, miss As Long
    For i = 1 To 32: For j = 1 To 32
        If mask(i, j) Then
            If Abs(Me.Pixel(i, j).Luminance - target.Pixel(i, j).Luminance) < 10 _
                And Abs(Me.Pixel(i, j).Hue - target.Pixel(i, j).Hue) < 10 _
            Then
                hit = hit + 1
            Else
                miss = miss + 1
            End If
        End If
    Next j, i
    EvalSimilarityScore = Round((hit / (hit + miss)) * 100, 0)
End Function

Sub CreateMask(blend As BitmapObject)
    ReDim mask(1 To 32, 1 To 32)
    Dim i As Long, j As Long
    For i = 1 To 32: For j = 1 To 32
        If Me.Pixel(i, j).Luminance < 200 _
            And Abs(Me.Pixel(i, j).Luminance - blend.Pixel(i, j).Luminance) < 10 _
        Then
            mask(i, j) = True
        Else
            mask(i, j) = False
        End If
    Next j, i
End Sub

Public Sub MoveFile(path)
    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists(path) Then
            .MoveFile FilePath, path
            FilePath = path
        Else
            Err.Raise vbObjectError, "BitmapObject", "移動先のパスがありません。"
        End If
    End With
End Sub

Public Property Get Self() As Object
    Set Self = Me
End Property

Public Function IsSame(bmp As BitmapObject) As Boolean
    IsSame = bmp.ToString = Me.ToString
End Function

Private Function GetBMPPixel() As Long()
    Dim hDC As Long: hDC = CreateCompatibleDC(0)
    Dim hBMP As Long: hBMP _
        = LoadImage(0, FilePath, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
    Call SelectObject(hDC, hBMP)
    
    Dim ret() As Long
    ReDim ret(1 To 32, 1 To 32)
    Dim x As Long, y As Long
    For y = 1 To 32: For x = 1 To 32
        ret(x, y) = GetPixel(hDC, x - 1, y - 1)
    Next x, y
    GetBMPPixel = ret
    Call DeleteDC(hDC)
    Call DeleteObject(hBMP)
End Function

Public Sub SetFile(path As String)
    FilePath = path
    colorArray = GetBMPPixel
    
    Dim Pics() As Byte
    Open path For Binary As #1
        ReDim Pics(LOF(1))
        Get #1, , Pics
    Close #1
    ToString = Pics
End Sub

標準モジュール

ここで、FileSystemObjectを使用するため、Microsoft Scripting Runtimeを参照設定しておく。
次に標準モジュールに以下のコードを書いて実行する。※パス等は適宜環境に合わせて設定が必要。

Sub 類似画像選り分け()
    Const 基準パス = "C:\Work\imageMSO\unique\"
    Const 振分け先 = 基準パス & "File\"
    Const 基準ファイル = 振分け先 _
        & "CustomFooterGallery.bmp"
    Const フィルタ作成用ファイル = 振分け先 _
        & "CustomPageNumberBottomGallery.bmp"

    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    Dim base As BitmapObject: Set base = New BitmapObject
    base.SetFile 基準ファイル
    
    With New BitmapObject
        .SetFile フィルタ作成用ファイル
        base.CreateMask .Self
    End With
    
    Dim f As File
    On Error Resume Next
    For Each f In fso.GetFolder(基準パス).Files
        With New BitmapObject
            .SetFile f.path
            If base.EvalSimilarityScore(.Self) > 70 Then
                .MoveFile 振分け先
            End If
        End With
    Next
    On Error GoTo 0
End Sub

実行結果

このとおり、類似画像が集まってきた。

ただ一部、端が折れてないものも混じってくる。

類似画像選り分けマクロの基準値を70から60に下げて実行してみると、さらに多くのファイルが取得できたが、関係ないアイコンが混じる確率も上昇する。

            If base.EvalSimilarityScore(.Self) > 60 Then
                .MoveFile 振分け先
            End If

さて、一応類似画像を取得できるようになったものの、取れてない画像も相当数ある。
以下は最初の基準でとれなかった画像。

それもそのはずで、人間はファイルアイコンというカテゴリで一括りできてもコンピューターだと少しでもズレてると難しい。

そこで改めてExcelのファイルアイコンを基準にパワポのファイルアイコンをフィルター作成用に用いて実行したところ、Office系のファイルアイコンがごっそりとれた。

というわけで一部の類似アイコン振分けはすこーしだけ楽になった。
ただそのように機械的に振分けするのが難しいアイコンが大量にあるので結局地道な作業は必要になる。