前回、アドインのリボンで使用できるImageISOをビットマップで保存するという記事を書いた。
実際に保存してみたところ、その数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で機械学習もどきをやってみようと思う。
あくまで「もどき」である。精度は出ないのであまり期待せずにお待ちを。
