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

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

thom.hateblo.jp

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

たとえば以下の3つ。

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

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

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

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

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

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

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

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

Function ReadBmpAsString(file_name AsString)AsStringDim bmp()AsByteOpen file_name ForBinaryAs#1ReDim bmp(LOF(1))Get#1,, bmp
    Close#1
    ReadBmpAsString = bmp
EndFunction

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

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

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

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

    Debug.Print fileA = fileB
    Debug.Print fileA = fileC
    Debug.Print fileB = fileC
EndSub

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

True
False
False

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

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

Subユニークファイル抽出()Dim t AsDouble
    t =TimerConst 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 AsString, uniqueImage AsVariantForEach f In fso.GetFolder(IMAGE_FOLDER).Files
        bmp = ReadBmpAsString(f.Path)ForEach uniqueImage In uniqueImages
            If bmp = ReadBmpAsString(CStr(uniqueImage))ThenGoTo Continue
            EndIfNext
        uniqueImages.Add f.Path
Continue:
       '待ち時間の目安になるよう画像100個につき1度Printする。Dim cnt AsLong: cnt = cnt +1If cnt Mod100=0Then
            Debug.Print cnt
            DoEventsEndIfNext
    Debug.PrintTimer- t
    t2 =TimerForEach uniqueImage In uniqueImages
        fso.CopyFile uniqueImage, IMAGE_FOLDER &"unique\"Next
    Debug.PrintTimer- t2
    Debug.PrintTimer- t
EndSub

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

40分かかった。。orz

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

ということでテイク2！

Subユニークファイル抽出Take2()Dim t AsDouble
    t =TimerConst 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
    ForEach f In fso.GetFolder(IMAGE_FOLDER).Files
        Images.AddArray(f.Path, ReadBmpAsString(f.Path))NextDim uniqueImages As Collection: Set uniqueImages _=New Collection
    Dim bmp AsVariant, bmp2 AsVariantForEach bmp In Images
        ForEach bmp2 In uniqueImages
            If bmp(1)= bmp2(1)ThenGoTo Continue
            EndIfNext
        uniqueImages.Add bmp
Continue:
       '待ち時間の目安になるよう画像100個につき1度Printする。Dim cnt AsLong: cnt = cnt +1If cnt Mod100=0Then
            Debug.Print cnt
            DoEventsEndIfNext
    Debug.PrintTimer- t
    t2 =TimerForEach bmp In uniqueImages
        fso.CopyFile bmp(0), IMAGE_FOLDER &"unique\"Next
    Debug.PrintTimer- t2
    Debug.PrintTimer- t
EndSub

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

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

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

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

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