VBA Excel表をHTMLのtableタグに変換するマクロ

先日メインサイトにXlRgbColor定数の一覧を掲載した。

色順に並べたXlRgbColor定数の一覧表 - You.Activate

今回はこれを作る時に使用したExcelマクロを題材に、VBAでExcel表からtableタグを出力する方法について記す。

まずHTML化する前のExcel表を用意しておく。

今回使用したのはこちら。

※7色で画面から切れてるが、実際は137色ある。

これを、冒頭で紹介したようにWebページで表示させるには、HTML形式に変化しなければならない。
具体的には、Excel表を以下のようなHTMLに変換する必要がある。

<table>
<tr>
<th>No</th>
<th>色</th>
<th>名前</th>
<th>RGB値</th>
<th>説明</th>
</tr>

<tr>
<td class="col0">1</td>
<td class="col1" style="background-color:#800000; width:30px;">　</td>
<td class="col2">rgbMaroon</td>
<td class="col3">128, 0, 0</td>
<td class="col4">栗色</td>
</tr>
<tr>
<td class="col0">2</td>
<td class="col1" style="background-color:#8b0000; width:30px;">　</td>
<td class="col2">rgbDarkRed</td>
<td class="col3">139, 0, 0</td>
<td class="col4">濃い赤</td>
</tr>

<!--以下略 -->
</table>

Excel表をhtml化するWebツールもあったが、セルの色までは再現してくれなかったので自作方法を覚えておくと役に立つかもしれない。

さて、タイトルでtableタグに変換するマクロと書いたが、実際にマクロで出力するのはtableの中身である、tdタグ
tableタグとthタグ(テーブルのヘッダー)もマクロで作ることはできるが、それほど手間でもないので今回は手入力とした。

マクロと手入力の分担は以下の通り。

<!-- ここから手入力 -->
<table>
<tr>
<th>No</th>
<th>色</th>
<th>名前</th>
<th>RGB値</th>
<th>説明</th>
</tr>
<!-- ここまで手入力 -->

<!-- ここからマクロ -->
<tr>
<td class="col0">1</td>
<td class="col1" style="background-color:#800000; width:30px;">　</td>
<td class="col2">rgbMaroon</td>
<td class="col3">128, 0, 0</td>
<td class="col4">栗色</td>
</tr>
<tr>
<td class="col0">2</td>
<td class="col1" style="background-color:#8b0000; width:30px;">　</td>
<td class="col2">rgbDarkRed</td>
<td class="col3">139, 0, 0</td>
<td class="col4">濃い赤</td>
</tr>
<!-- ここまでマクロ -->

<!-- 以下略 -->
<!-- tableの閉じタグも手入力 -->
</table>

つまり実際にマクロでは、以下テンプレートの[No]、[色値]、[色名]、[RGB値]、[説明]をループで次々と変更しながら出力すれば良いということ。

<tr>
<td class="col0">[No]</td>
<td class="col1" style="background-color:#[色値]; width:30px;">　</td>
<td class="col2">[色名]</td>
<td class="col3">[RGB値]</td>
<td class="col4">[説明]</td>
</tr>

※tdタグにそれぞれclassを付けたのは、列ごとに後からフォントサイズを調整しやすくするため。

さて、ここから実際にマクロを作成していく。

検証段階ではとりあえずDebug.PrintでHTMLを出力させるが、イミディエイトウインドウへは200行までしか出力できず、切れてしまう。
後で簡単にテキストファイルへの書き出しに切り替えられるよう一旦WriteLineというプロシージャを作っておこう。

Sub WriteLine(message)
    Debug.Print message
End Sub

こうすればマクロが完成した後にWriteLineの中身を書き変えることで出力先をテキストファイルに切り替えられる。
※こうした保守性の観点からのプロシージャ分割も重要。

次に今回はXlRgbColorの色見本を扱うので、テーブルのセルの背景色をそれぞれ個別に指定する必要がある。
出力するのはHTMLなので16進数の色表記を用いる必要があるが、Excel表では単なるRGBのLong値なので、これを16進数の文字列に変換するための関数もあらかじめ作っておく。

以下がその関数。RGB値を渡すと、HTMLで使用する16進数に変換してくれる。

Function RGBToHTMLColor(color_rgb)
    Dim r: r = color_rgb \ 256 ^ 0 Mod 256
    Dim g: g = color_rgb \ 256 ^ 1 Mod 256
    Dim b: b = color_rgb \ 256 ^ 2 Mod 256
    Dim hexR: hexR = Right("0" & Hex(r), 2)
    Dim hexG: hexG = Right("0" & Hex(g), 2)
    Dim hexB: hexB = Right("0" & Hex(b), 2)
    RGBToHTMLColor = "#" & hexR & hexG & hexB
End Function

そして、出力したい表のあるエクセルシートのシートモジュールに以下を張り付けて実行すると、イミディエイトウインドウにHTMLが出力される。

Sub 表をHTML化()
    For 行 = 2 To 138
        WriteLine "<tr>"
        For 列 = 1 To 5
            If 列 = 2 Then
                Dim backGroundColor As String
                backGroundColor = RGBToHTMLColor(Cells(行, 4).Value)
                WriteLine "<td class=""col1"" style=""background-color:" _
                    & backGroundColor & "; width:30px;"">　</td>"
            Else
                WriteLine "<td class=""col" & 列 - 1 & """>" _
                    & Cells(行, 列).Value & "</td>"
            End If
        Next
        WriteLine "</tr>"
    Next
End Sub

注意：(私にとっては)単発ものなので、変数宣言もしてないしループ回数もリテラルべた打ち。良いコードとは言えないので、こちらを参考に汎用的なマクロを作る場合は適宜きちんと書いて。

さて、イミディエイトウインドウでは200行以上出力すると古いものから順に消えてしまうのでテキストファイルへの出力に変更したい。
ここでFileSystemObjectを使用するので、Microsoft Scripting Runtimeを参照設定しておく。

そしてWriteLineを以下のように書き換える。

Sub WriteLine(message)
    With New FileSystemObject
        Dim ts As TextStream
        Set ts = .OpenTextFile("c:\work\writeline.txt", ForAppending, True)
        ts.WriteLine message
        ts.Close
    End With
End Sub

※みなさんが利用する場合、パスは適宜変更が必要。また、追記モードで開くので試行錯誤する場合はいったんファイルの中身を消す必要がある。

これでtableの中身がテキストに出力されるので、あとは手入力のtableタグの中に張り付けるだけ。

VBA プロシージャのオーバーロード機能(もどき)を自作する

今回のネタは@mmYYmmddさんのつぶやきから生まれた。感謝。

さて、オーバーロードとは。
ふつう、Functionが取れる引数の数や型は固定されていてあまり自由が利かないのだが、引数の数や型によって処理を振り分けたい場合がある。
VariantやOptional、ParamArrayを活用することでこのような処理も可能であるが、一つの関数で処理を振り分けるとごちゃごちゃしてしまいメンテナンス性が落ちる。

これを解決するのがオーバーロードである。オーバーロードとは、引数の数もしくは型が違えば同名のプロシージャをいくつでも作成できる機能で、JavaやC#、C++などの言語には実装されている。
これを使えばあくまで別の関数として作れるので、複雑にならずにすむ。

残念ながら、VBAにその機能はない。そこで今回はオーバーロード（もどき）を実装してみたい。
業務コードでこれをすると複雑になるだけなので、ライブラリコードでしか使い道はないけど。

まず引数の型を判定するための関数をFunctionプロシージャで作成。

Function GetArgTypeString(ParamArray args()) As String
    Dim ret As String
    For Each x In args
        Select Case True
        Case IsMissing(x): ret = ret & "M"
        Case IsArray(x): ret = ret & "A"
        Case IsObject(x): ret = ret & "O"
        Case TypeName(x) = "String": ret = ret & "S"
        Case IsDate(x): ret = ret & "D"
        Case IsNumeric(x): ret = ret & "N"
        Case Else: ret = ret & "U"
        End Select
    Next
    GetArgTypeString = ret
End Function

この関数にいくつか引数を渡すと、文字列で型が返ってくる。
たとえば、1, #2017/3/5#, "Hello" の順で渡すと、NDSとなる。Number、Date、Stringである。

次に、たとえばAddという関数を作りたい場合、Addに先ほどの文字列をつけた名前で関数を作る。
タイプごとに4つ用意した。

Function AddSSM(a, b)
    AddSSM = a & b
End Function
Function AddSSS(a, b, c)
    AddSSS = a & b & c
End Function
Function AddNNM(a, b)
    AddNNM = a + b
End Function
Function AddDNM(a, b)
    AddDNM = a + b
End Function

そして、渡された引数によって実際の関数へ処理を引き渡すための、窓口となる関数を作る。
これが本来呼び出したいAdd関数。

Function Add(a, b, Optional c)
    Dim typeString As String
    typeString = GetArgTypeString(a, b, c)
    Add = Application.Run("Add" & typeString, a, b, c)
End Function

あとはメインコード。

Sub Main()
    Debug.Print Add(1, 2)
    Debug.Print Add("1", "1a")
    Debug.Print Add(#3/5/2017#, 1)
    Debug.Print Add("A", "B", "C")
End Sub

実行するとこのとおり。

 3 
11a
2017/03/06 
ABC

まぁ使い物になるかどうかはわからないが、私が類似の問題を抱えたときにアイデアの叩き台になればと思い、ここに残しておく。

念押しするが、アプリケーションコードでコレは余計複雑になるだけなのでやめておいたほうが賢明。ただライブラリを書く目的ならこういうのもアリかなと思う。

VBA 入門書を再評価する ～ チャレンジングな5冊をピックアップして劇甘レビュー

私は普段マニアックな記事ばかり書いてるが、実は入門者向けの教材なんてのも書いている。

さりげないアッピールはいやらしいので、堂々といこう。

宣伝！みんな、見てねっ！

EXCEL VBA 入門教材　急がば回れ！文法から覚えるやさしいVBA 入門

ダウンロードはこちら↓（無料）
ダウンロード - You.Activate

おっと。

今回はそれが本題ではなくて、巷のVBA入門書について。

私の教材のまえがきで、このように書いた。

すでに VBA の入門書はたくさん出回っていますが、私が知る限りはどれも似たような構成になっています。はじめにマクロの自動記録、それからセルの操作などが続いて最後の方に申し訳程度に文法などが紹介されています。
VBA 以外の他のプログラミング言語は、まず文法から学習します。文法はプログラミング言語の要ですので、ここをしっかり理解しないことには、役に立つプログラムは作れません。しかしなぜか VBA に限っては文法を中心に解説された入門書が見つからず、前述のような状況です。

さて、自信満々に書いたものの単に私がそれほど多くの入門書を知らないだけということもありうる。
どれも似たような構成って、じっくり読んでもないのになんて失礼なこと言うんだろう、私。

ただ私が「どれも似たような」と書いたのは「構成」についてであって、似たような説明だとも、似たようなデザインとも、似たようなプログラムとも言ってない。それぞれの入門書をじっくり読んでみると、いかに分かりやすく読者に説明するか、涙ぐましい工夫が満載で、本気で「この本でプログラムができるようになってほしい」という想いが伝わってくる。

王道的な書籍も良いけど、私は新しい解説手法にチャレンジした書籍が好きで応援したくなる。

今回は私が特に気にいったチャレンジングな書籍について5冊レビューしよう。
どれも似たような構成と書いてしまったお詫びも込めて、わざとらしいくらい褒めちぎろう。

各書籍ごとのチャレンジをレビュー

Excel VBA 超入門教室 Excel2010/2007/2003対応 (教えて!蔵之介先生シリーズ)

Excel VBA 超入門教室 Excel2010/2007/2003対応 (教えて!蔵之介先生シリーズ)

[レビュー]
対話形式で、登場人物の美咲さんがコロコロ表情を変えるので超カワイイ。蔵之介のまったく変化しないシュールな顔も良い。Amazonのなか見検索で見られるので是非！更に題材として複数のブックから一つのリストへ転機するという超実用的なものを扱っており、即戦力になる。いや、そんなことより美咲さんがカワイイ！
すばらしい！

Excel2013/2010限定版 やさしく学ぶ エクセルVBA

Excel2013/2010限定版 やさしく学ぶ エクセルVBA

[レビュー]
この書籍も対話形式。しかし私が気に入った工夫点はそこではなく、とにかくプログラムの文字が大きくハッキリしていること。
おそらくConsolasフォントを使ってると思われ、ゼロとオーの取り違えやアイとイチの取り違えもしにくい。
実物を見ると、でかっ！て突っ込んでしまいそうなくらい大きい文字であるが、まったく初めての方が写経するにはちょうど良い。プログラミングではドットやダブルクォーテーションなどの小さな記号をよく使うので、文字が小さいと見落としてハマってしまうことがあるが、この本は大きな文字で見落としにくい。
更に初心者に配慮して異例の日本語変数採用。入力は少し煩わしくなるけど、プログラムの理解しやすさはダントツ。
日本語変数はどちらかといえば否定されがちだけど、少しでも入門者に易しくという配慮はすばらしいチャレンジである。
感動した！

できるExcel マクロ＆VBA 作業の効率化＆スピードアップに役立つ本 2016/2013/2010/2007対応 できるシリーズ

(無料電話サポート付)できるExcel マクロ&VBA 作業の効率化&スピードアップに役立つ本 2016/2013/2010/2007対応 (できるシリーズ)

[レビュー]
上級者が鼻で笑う「できる」シリーズ！おっと失礼。ただ私も正直ちゃんと読むまではバカにしてたのだ。ずっと生き残ってるし新しいOfficeが出るたびにすぐ出てくるので売れてるんだろうなとは思っていた。この書籍の良いところは膨大なスクリーンショットの数である。画面そのままなので、吹き出しに従って操作すれば一通り学習を進めることができる。ごちゃっとした印象を受けるのはサイドカラムのヒント情報量の多さによるもので、実際にはメインカラムの画像の指示に従って進めるのでそこまで不便ではない。
日本語変数を採用しているのも初心者向けの配慮として良い。まぁこのシリーズにおける日本語変数はチャレンジングというより割り切りに近いものかなと思うけれど。
それと驚いたのが無料電話サポートが付いている点。VBAを電話でサポート？正気かコイツら。。質問時間に制限はあるもののの、これはすごいチャレンジだ。
グレイト！

自分のペースでゆったり学ぶ Excel VBA

自分のペースでゆったり学ぶ Excel VBA

[レビュー]
この書籍の良いところは、「ドット」を日本語の「の・を」であると言い切ってしまったところ。
説明が全般的にわかりやすく、初心者を想定した読みやすい文章で専門書を読んでいるというよりふつうの書籍のようにスラスラ読める。
熊のイラストも良い。熊がカワイイってより、これを描いた女性らしい感性が素敵。見ていてほのぼのする。
グッジョーブ！

ExcelVBA超入門講座 Excel2010/2007対応

ExcelVBA超入門講座 Excel2010/2007対応

[レビュー]
これ、私にとって大本命！楽しさは他の書籍に譲る。硬派なあなたにピッタリの本格的なプログラミング入門書。
というのもこの本、「マクロの記録をしてみましょう」なんて甘っちょろいことはせずに最初から文法の要を説明している。
プログラミングは基本制御構造「順次」「選択」「繰り返し」でできている。つまりこれが要になるわけで、これがわからないといかなる便利なプログラムも組みようがないのだ。これが現実である。
他の書籍は幻想を見せてくれる。だが現実はつらい。乗り越えられる人もいるけど、挫折してしまう人も多い。この書籍では初っ端から現実にご対面だ。下手なごまかしはせず、サバイバルに必要な「道具」を最初から持たせてくれる。
エクセレント！

この書籍に対しては、私は「どれも似たような構成」という前言を撤回せねばならない。
お詫びおよび、最大限の賞賛として「購入」を贈る。

さっきAmazonでポチった。

あとがき

本当は入門書の目次構造をひととおり調べたので、他言語の目次と比較しながら変数や制御構造の説明が登場するタイミングについて書き、Excel プログラミングの特殊性について触れたかったのだけど、その際に入門書にきちんと目を通してみたら以外と良い点、工夫されている点が多く見られたのでお詫びと賞賛を込めていろいろ書いてたら当初の目的がそっちのけになってしまった。

長くなりすぎるのとレビューはレビューで一旦区切っておいたほうが利便性が良いかなと思うので今回はここで終わり。
次回、、、かどうかは分からないけどそのうち「VBA 入門書の目次から考察するExcelプログラミングの特殊性」について書こうと思う。

VBA パスカル記法を単語ごとに区切って配列で返すSplitPascal関数を自作する

今回はパスカル記法を単語ごとに区切って配列で返す関数を作成する。

前回このような記事を書いたのだが、
thom.hateblo.jp

この記事を受けて@Dev_Clipsさん(サイト)からツイッターで「ImageMsoの"名前"の一致率も類似画像抽出に使えそう」とのヒントを貰ったためだ。

さて、ImageMSO画像のファイル名はパスカル記法になっている。

パスカル記法とは、英単語を並べる際、単語の始まりをすべて大文字にしてスペースを入れずにくっつけた形。

例) ThisIsAPascalNotation

今回作成するのはこれを単語単位に分割し、配列に格納するための関数である。
SplitPascal関数と名付けよう。

まぁただコード書いて終わりではあんまりなので、今回は作成プロセスを追って紹介するスタイルで書く。
くどいほど少しずつ組み立ててみよう。
Functionプロシージャの組み立て方がいまひとつ難しいという方の参考になれば幸いである。

1) 枠組みを作る

Function SplitPascal()
End Function

2) 引数、戻り値を決める

今回は文字列を渡すのでString型の引数を一つだけ。

Function SplitPascal(expression As String)
End Function

戻り値は今回Variant型にするので何も書かない。

3) 戻り値を返す処理を書く

戻り値の型はVariantであるが、そこに含める中身は配列なので、配列型でret変数を作ってとりあえずそれを返す処理にする。

Function SplitPascal(expression As String)
    Dim ret()
    SplitPascal = ret
End Function

ここまでが定石。どのようなFunctionでもこの流れで作れるのでマスターしよう。
あとは戻り値であるretをどう作りこんでいくかである。

4) 1文字ずつループさせるための、枠組みを作る

1文字ずつ検査して大文字かどうかを見る必要があるので、とりあえず文字数分ループ。

Function SplitPascal(expression As String)
    Dim ret(), i
    For i = 1 To Len(expression)
        '処理
    Next
    SplitPascal = ret
End Function

5) 1文字ずつ切り出してプリントしてみる

このあと文字を切り出して、検査・加工するのだが、その前にとりあえず動作がわかるようにプリント文にしておく。

Function SplitPascal(expression As String)
    Dim ret(), i
    For i = 1 To Len(expression)
        Debug.Print Mid(expression, i, 1)
    Next
    SplitPascal = ret
End Function

6) 呼び出してみる

メインコードを書いて呼び出してみる。まだ戻り値も何も使わないけど、とりあえず1文字ずつプリントされるところまで確認。

Sub Main()
    SplitPascal "ThisIsAPascalNotation"
End Sub

7) 大文字かどうかの判定

ここで文字コードの知識が活きる。といってもコードは知らなくても大丈夫。A～Zが連番になってることを知ってれば、Asc関数とIf文で切り出した文字がA～Zの範囲に収まっているか調べられる。

Function SplitPascal(expression As String)
    Dim ret(), i
    For i = 1 To Len(expression)
        Dim char: char = Mid(expression, i, 1)
        If Asc("A") <= Asc(char) And Asc(char) <= Asc("Z") Then
            Debug.Print "★"
        End If
        Debug.Print char
    Next
    SplitPascal = ret
End Function

このとき、大文字だったら★をプリントしたのち、charを出力。大文字でなければcharだけ出力される。
イミディエイトはこんな感じ。

さて、ここで閃いた。これ、一文字ずつ出力しているが、★をスペースに置き換えて一つの文字列に足していったらどうか。

8) スペース区切りで出力

retを配列ではなくてただのString型に変更し、ここに結果文字列を足しこんでいく。

Function SplitPascal(expression As String)
    Dim ret As String, i
    For i = 1 To Len(expression)
        Dim char: char = Mid(expression, i, 1)
        If Asc("A") <= Asc(char) And Asc(char) <= Asc("Z") Then
            ret = ret & " "
        End If
        ret = ret & char
    Next
    SplitPascal = ret
End Function

メインコードは戻り値を出力する形に変更。

Sub Main()
    Debug.Print SplitPascal("ThisIsAPascalNotation")
End Sub

すると、イミディエイトウインドウに「 This Is A Pascal Notation」と出力される。
このままでは先頭に1つスペースが入ってるうえ、当初の目的である配列で返すってのができていない。

9) 最後の仕上げ

まあここまで来ればあとは簡単。
余計なスペースの件はTrim関数で解決するし、配列になってない件はSplit関数で解決する。
ということで、戻り値の代入部分をちょっといじるだけ。

Function SplitPascal(expression As String)
    Dim ret As String, i
    For i = 1 To Len(expression)
        Dim char: char = Mid(expression, i, 1)
        If Asc("A") <= Asc(char) And Asc(char) <= Asc("Z") Then
            ret = ret & " "
        End If
        ret = ret & char
    Next
    SplitPascal = Split(Trim(ret))
End Function

メインコードも配列を処理するよう変更

Sub Main()
    Dim word
    For Each word In SplitPascal("ThisIsAPascalNotation")
        Debug.Print word
    Next
End Sub

出力結果はこちら

This
Is
A
Pascal
Notation

以上で完成。

ただ当初の目的であったImageMSOへの応用はあまり芳しくなく。。
なんか名前ベースで探しても毛色の違うアイコンが結構ヒットするので苦労中。

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系のファイルアイコンがごっそりとれた。

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

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

完成！！

はい、今回はここまで。

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で機械学習もどきをやってみようと思う。

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