VBAで2つの画像ファイルを比較して内容が同一かどうかを判定する方法

前回、アドインのリボンで使用できるImageISOをビットマップで保存するという記事を書いた。

thom.hateblo.jp

実際に保存してみたところ、その数8425点。しかし名前が違うだけで同じ画像がたくさんある。

たとえば以下の3つ。

これらは特定画像を探したいときにノイズになる。

ということで、今回は名前が異なる同じ画像を排除し、ユニークなものだけを選り分ける方法を紹介する。

これを実現するためには、まず2つの画像を比較して同一かどうかを判定できれば良い。それさえ片付けば、あとはループで回すだけ。

正攻法でいくならビットマップのピクセルをそれぞれ比較するという方法があるが、今回はもっと簡単な方法を採用した。

それは、画像をバイナリデータとしてByte型配列に読み込ませた後、String型に変換してイコールで比較演算する方法である。

VBAでバイナリデータを読み込む方法は過去にやったことがある。以下の記事だ。
thom.hateblo.jp

また、String型の実態はByte型配列であることは以下の記事で述べた。
thom.hateblo.jp

それらを応用して作ったのが、ビットマップ画像を文字列型として返す関数。

Function ReadBmpAsString(file_name As String) As String
    Dim bmp() As Byte
    Open file_name For Binary As #1
        ReDim bmp(LOF(1))
        Get #1, , bmp
    Close #1
    ReadBmpAsString = bmp
End Function

もちろん画像は文字列ではない。しかし実はString型には文字として表現できないデータも含めることができるのだ。なぜならその実態はByte型配列だから。バイナリデータをString型に格納することができるのはそういうこと。

配列同士を比較しようと思ったら1要素ずつループさせるしかないが、String型なら単にイコールで比較できる。

では実際に試してみよう。

Sub ファイルの比較()
    Const IMAGE_FOLDER = "C:\Work\imageMSO\"
    Dim fileA As String: fileA _
        = ReadBmpAsString(IMAGE_FOLDER & "AcceptProposal.bmp")
    
    Dim fileB As String: fileB _
        = ReadBmpAsString(IMAGE_FOLDER & "AcceptInvitation.bmp")
    
    Dim fileC As String: fileC _
        = ReadBmpAsString(IMAGE_FOLDER & "AcceptAndAdvance.bmp")

    Debug.Print fileA = fileB
    Debug.Print fileA = fileC
    Debug.Print fileB = fileC
End Sub

結果はこのようになった。

True
False
False

この結果はつまり、AcceptProposal.bmpとAcceptInvitation.bmpは実質同じ画像であるが、AcceptAndAdvance.bmpは別の画像であるということを示している。

よし、これでいける。。
と思って以下のマクロを組んでみた。

Sub ユニークファイル抽出()
    Dim t As Double
    t = Timer
    Const IMAGE_FOLDER = "C:\Work\imageMSO\"
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    
    Dim uniqueImages As Collection
    Set uniqueImages = New Collection
    Dim f As File, bmp As String, uniqueImage As Variant
    For Each f In fso.GetFolder(IMAGE_FOLDER).Files
        bmp = ReadBmpAsString(f.Path)
        For Each uniqueImage In uniqueImages
            If bmp = ReadBmpAsString(CStr(uniqueImage)) Then
                GoTo Continue
            End If
        Next
        uniqueImages.Add f.Path
Continue:
        '待ち時間の目安になるよう画像100個につき1度Printする。
        Dim cnt As Long: cnt = cnt + 1
        If cnt Mod 100 = 0 Then
            Debug.Print cnt
            DoEvents
        End If
    Next
    Debug.Print Timer - t
    t2 = Timer
    
    For Each uniqueImage In uniqueImages
        fso.CopyFile uniqueImage, IMAGE_FOLDER & "unique\"
    Next
    Debug.Print Timer - t2
    Debug.Print Timer - t
End Sub

実行前にc:\work\ImageMSO\uniqueフォルダを作成しておく。
かなり時間がかかることが予測されるので100ファイルごとに1回Debug.Printで経過を表示させることに。
さらにトータルの秒数をカウントしてみたところ、、

40分かかった。。orz

メモリが膨らむのを懸念して比較対象のファイルを毎回ReadBmpAsStringで変換させているのだが、これは明らかに失敗だった。よく考えみれば今回のアイコンは1ファイルたかだか3KBなのだ。約8500個すべてメモリにロードしたとしてもトータルで25MBほどにしかならない。

ということでテイク2！

Sub ユニークファイル抽出Take2()
    Dim t As Double
    t = Timer
    Const IMAGE_FOLDER = "C:\Work\imageMSO\"
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    
    Dim Images As Collection: Set Images _
        = New Collection
    Dim f As File
    For Each f In fso.GetFolder(IMAGE_FOLDER).Files
        Images.Add Array(f.Path, ReadBmpAsString(f.Path))
    Next
    
    Dim uniqueImages As Collection: Set uniqueImages _
        = New Collection
    Dim bmp As Variant, bmp2 As Variant
    For Each bmp In Images
        For Each bmp2 In uniqueImages
            If bmp(1) = bmp2(1) Then
                GoTo Continue
            End If
        Next
        uniqueImages.Add bmp
Continue:
        '待ち時間の目安になるよう画像100個につき1度Printする。
        Dim cnt As Long: cnt = cnt + 1
        If cnt Mod 100 = 0 Then
            Debug.Print cnt
            DoEvents
        End If
    Next
    Debug.Print Timer - t
    t2 = Timer
    
    For Each bmp In uniqueImages
        fso.CopyFile bmp(0), IMAGE_FOLDER & "unique\"
    Next
    Debug.Print Timer - t2
    Debug.Print Timer - t
End Sub

なんと！
56秒で終了！！約48倍速！

まぁ考えてみれば当たり前で、最大のネックであるファイルオープン回数が全然違う。
イメージの数を約8500個として、最初のマクロだと、uniqueImagesに1個ある状態なら8500×1回、2個たまれば8500×2回、1000個たまれば8500×1000回と、途方もないファイル読み込みが発生しているが、テイク2ではファイル読み込みは最初の8500個のみ。あとはメモリ上に展開されたコレクション同士の比較で済むのできわめて高速だ。

ざっくり言って、メモリはHDDと比べて1万倍高速、SSDと比べても1000倍高速らしい。
qiita.com

さて、なにはともあれユニークなアイコン画像のみを抽出するところまでできた。
次回はこれを更に自動である程度分類するため、VBAで機械学習もどきをやってみようと思う。

あくまで「もどき」である。精度は出ないのであまり期待せずにお待ちを。