読者です 読者をやめる 読者になる 読者になる

t-hom’s diary

主にVBAネタを扱っているブログです。

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

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

thom.hateblo.jp

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

たとえば以下の3つ。
f:id:t-hom:20170225234034p:plain

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

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

これを実現するためには、まず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機械学習もどきをやってみようと思う。

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

VBA アドイン作成で使用するリボンアイコンの組み込み画像(ImageMSO)をBitmapで一括保存する方法

目次

能書き ~ うんたらかんたら

Excel、Word、PowerPointでは作成したマクロをアドインとして保存することができる。また、オリジナルのリボンタブを作ってマクロを登録しておくと配布された側はリボンからボタンを押すだけで使えるので便利だ。

マクロ実行用のボタンにはアイコンを付けることができる。アイコンに使用できる画像はあらかじめOfficeに組み込まれている。種類も豊富なので選び放題。実行するマクロのイメージにマッチしたアイコンを選択することで、まるでプロが作った本格的な製品のように格好いいアドインになる。

と、こ、ろ、が。。

作る方はこれ、超めんどうくさい。(@_@;)

まずファイルを保存して閉じて、拡張子に.zipを付けてからExploreで開き、中にある「.rels」を編集し、さらにCustomUIというフォルダを作成して中に自分で作ったCustomUI.xmlを配置し、一旦Explorerを閉じて拡張子を元に戻してから開きなおすとようやくデザインしたリボンが現れる。

やったことない方は、この時点でちょっと引いてると思う。
まぁ、これはそんなに難しくない。また、リボンを作るための専用のツールもあるので、そういうのをダウンロードできる職場ならまぁ比較的楽に作れるだろう。

ツールを使ったリボンのカスタマイズはこちらがおススメ。
Office 2007/2010・リボンのカスタマイズ 初心者備忘録

ちなみに私の職場ではそうした外部ツールのダウンロードは禁止されているので、やはり手でXMLをいじるしかないのだけど。

Excel2013の方はこちらで手でリボンを作成する方法を動画で紹介した。
thom.hateblo.jp
※訳あって今は2010をメインで使ってて、2010だとxmlが微妙に違うのでこのままでは使えないのだけど、そこは適当に検索してほしい。

さて、しかし。
本当にめんどうなのは、そこじゃないんだ。

ナイスな画像を選ぶ。
これ。

これなんだよ。めんどうくさいのは。

好きなアイコンを選ぶってのは楽しそうに思えるかもしれないけど、Office2010に存在するアイコン名は約8600点。しかも系統別ではなく、アイコンの名称でアルファベット順に並んでいる。

しかも全く同じアイコンが別名で登録されてたりするもんだから、それらがノイズになって更に探しにくい。

アイコンサンプルを紹介しているサイトや図で選べるようなものもあるけれど、系統別に整理されたものは無く、私の知る限りすべてアルファベット順だ。

たとえば、こちらは2013のアイコン一覧。
www.ka-net.org

画像で見て探せるので、少なくともテキストだけよりは断然助かる。非常にありがたい。

しかし人間、欲深いもので、やっぱもっと楽に探したいなぁと思う。
たとえばファイルならファイルのアイコン、DBならDBのアイコンでまとまっていれば求めているものが探しやすい。

まぁ、それをサイトの主に求めるのはお門違いというもの。
それなら自分で作ってしまえ!ということで今回の記事はその前段階であるImageMSOをBitmapで保存するマクロの紹介。

前置きが長くなってしまったが、次項で実際にBitmap保存するマクロを紹介する。

全ImageMSOをBitmapで保存するマクロ

マクロを実行する前に、前準備が必要となる。
まずはImageMSOの一覧をMicrosoftのサイトからダウンロードしてくる。

Download Microsoft Office Document: [MS-CUSTOMUI2] Supporting Documentation from Official Microsoft Download Center
こちらのサイトでDownloadボタンを押すと何をダウンロードするか選択する画面になるので、「imageMSO.txt」にチェックを入れてダウンロードしよう。

そしてメモ帳などのエディタで開き、全選択してコピーする。
f:id:t-hom:20170225183249p:plain

そして、Excelに張り付ける。
f:id:t-hom:20170225183405p:plain

idMsoと書かれた1列目がImageMSOの名前である。
2列目が1ならOffice2010に存在し、3列目が1ならOffice2013に存在するという意味である。
ただ今回存在しないものはOn Errorで処理するので消してしまって良い。

次にImageMSOを保存するフォルダを作る。
今回はC:\work\ImageMSOとした。

そしてB列に保存するファイルのフルパスが入るように以下の数式を挿入する。

="C:\work\ImageMSO\"&A2&".bmp"

f:id:t-hom:20170225183903p:plain

最後にオートフィルで最終行10237まで埋めたら前準備は完成。
f:id:t-hom:20170225184207p:plain

次に、前準備に使用したシートのシートモジュールに以下のマクロを記述する。
今回はSheet1モジュールに記述した。

Sub SaveAllMsoAsBitmap()
    Dim bmp As IPictureDisp
    Dim cb As CommandBars: Set cb = Application.CommandBars
    Dim arr: arr = Range("A2:B10237").Value
    
    On Error Resume Next
        For i = LBound(arr, 1) To UBound(arr, 1)
            stdole.SavePicture cb.GetImageMso(arr(i, 1), 32, 32), arr(i, 2)
        Next
    On Error GoTo 0
End Sub

これを実行すると、C:\work\ImageMSOに次々とアイコンが保存される。

f:id:t-hom:20170225190000p:plain

A2:B10237とか、思いっきりハードコードしてるけど所詮一発ものなのでこれで十分。
ポイントはstdole.SavePictureと、cb.GetImageMsoである。

先ほど紹介した以下の記事の末尾にGetImageMsoメソッドの利用例が掲載されていたので、こちらを参考にさせていただいた。
www.ka-net.org

どうやらApplicationのCommandBarsオブジェクトにGetImageMsoというメソッドがあり、ここにImageMSOのID(つまり名前)を渡すと画像が得られるらしい。記事では80×80となっていたが、色々試した結果32×32にするとボケないことが分かったので今回は32×32で取得。

オブジェクトブラウザで確認すると、GetImageMsoはIPictureDispという型を返すようだ。
f:id:t-hom:20170225185356p:plain

それならこれを保存する手はないかと色々検索してたら、標準で参照されているstdoleライブラリにSavePictureという命令があることが分かった。

こちらもオブジェクトブラウザで確認してみる。
f:id:t-hom:20170225185552p:plain

確かにIPictureDisp型の値を引数に取っているようだ。

ということで、これらを組み合わせれば全ImageMSOの保存ができるというわけ。

今回はこれで以上。

次回は重複する画像の消し込みを紹介する。

VBA XlRgbColor定数をシート上に色相順、明るさ順で出力する

「あなたの好きな色は何色ですか?」と聞かれたら

赤、青、緑、黄、黒、白、紫…

まあ、普通はこんな感じで答えると思う。

ここで、狐色、若草色、深紅、枯草色といったちょっとこだわった感じの名前を返してくると、「おっ、情緒的でいいな」と思う。ラベンダー、アイボリー、アクアマリンなんて答えも素敵だ。

色にはそれぞれ素敵な名前がついている。その名前はモノを連想させたり、イメージを膨らませる。

さすがに団十郎茶、勿忘草色、空五倍子色、ラベンダーブラッシュ、コーンフラワーブルーなんて言われると「こいつ、ちょっとひねくれてるな」って感じがするけど。


団十郎て誰やねん。

団十郎茶(だんじゅうろうちゃ)とは、江戸時代の歌舞伎役者「市川團十郎」が代々用い…

団十郎茶(だんじゅうろうちゃ)とは?:日本の色・和色

知らんがな。
(いや、もちろん色を扱う特殊な職業の方なら良いと思う。)


さて、今回はVBAの色の話。
VBAではRGB関数を使って簡単に色を作成できるが、面倒くさくてもあえて名前で呼ぶというのは情緒があって良い。

それで、以前こんな記事を書いた。
thom.hateblo.jp

しかし、
案の定、面倒くさい。

何がって、探すのが。
まずもって色名をそんなに知らないうえ、シートに書き出しても英語名でアルファベット順なので。

f:id:t-hom:20170218054058p:plain
こっから選べって言われてもなぁ。。

普通、人間が色を探すときって、赤系とか青系といった色相(しきそう)や明るい、暗いといった輝度(きど)で探す。
※感覚的には濃い・薄いという用語のほうがシックリくるけど、あれは絵の具の話なので、ディスプレイ上は輝度(きど)

彩度も重要な要素だけど私は最初から彩度を基準に探すってことはしないので、一般的にもそうだと思う。

それで今回は、XlRgbColor定数を色相順、輝度順で出力してみたいと思う。

Win32APIにRGB値から色相、輝度、彩度を求めるColorRGBToHLS関数があるので、そちらを利用する。
※HLSはHue(色相)、Luminance(輝度)、Saturation(彩度)の意味

参考:ColorRGBToHLS function (Windows)

まずMSDNに色名の表があるのでそちらを選択してExcelに張り付ける。
https://msdn.microsoft.com/ja-jp/library/office/ff197459.aspx

セルの色もそれぞれの色に合わせておこう。詳しくは以下参照。
VBA 新しい色の指定方法 ~XlRgbColor定数 - t-hom’s diary

それから、シート上に色相、輝度、彩度を入力する箇所を設ける。
f:id:t-hom:20170218060449p:plain

次に標準モジュールに以下を貼り付ける。

Public Declare Sub ColorRGBToHLS Lib "Shlwapi.dll" (ByVal clrRGB As Long, _
     pwHue As Integer, pwLuminance As Integer, pwSaturation As Integer)

次にシートモジュールに以下を張り付ける。

Enum 列
    XlRgbColor定数名 = 1
    定数値
    日本語名
    色相
    輝度
    彩度
End Enum

Sub HLS値取得()
    Dim H, L, S, i
    For i = 2 To 143    '←単発モノなのでハードコード
        Debug.Print Cells(i,.定数値).Value
        Call ColorRGBToHLS(Cells(i,.定数値).Value, H, L, S)
        Cells(i,.色相) = H
        Cells(i,.輝度) = L
        Cells(i,.彩度) = S
    Next
End Sub

そしてHLS値取得を実行すると、色相、輝度、彩度が入力されるので、あとはオートフィルタで並び替えるだけ。

色相順に並べてみた。
f:id:t-hom:20170218061106p:plain

彩度の昇順で並び替えたあと、輝度の昇順で並び替えてみた。
f:id:t-hom:20170218061236p:plain

無彩色でフィルタリングしてみた。
f:id:t-hom:20170218061439p:plain

緑系だけフィルタリングしたのち、輝度・彩度の順に並び替えた。
f:id:t-hom:20170218061903p:plain

これで色がずいぶん探しやすくなった。

というわけで皆、色名も使ってあげて。

2017/03/04追記

サイトに表をアップしたので、こちらもご参照ください。
色順に並べたXlRgbColor定数の一覧表 - You.Activate

VBA オートシェイプで作った桜のアイコンでユーザーフォームを可愛くデコレーションする

普段からこのブログを読んでくれてる方は、今回のタイトルを見て「ついにthomもVBAのやり過ぎで頭がおかしくなってしまったか」と思われた方もいるかもしれない。

可愛くだなんて。30超えたオッサンが何言うとんねん。
さてさて、今回作ったのはこれ。

でん!
f:id:t-hom:20170212001539p:plain

きゃーカワイイー!

…まじめな話、最初からコレをねらった訳ではなく、こんなふうになってしまったのは偶然の産物である。

きっかけはイラストの重要性に気付いたこと

マクロの機能的にはアイコンなんて何の意味もないと思う方も居るかもしれないけど、ユーザーがそのマクロの使用感に満足を覚えるかどうかという点でデザインは超重要な要素だ。

繰り返す。

デザインは超重要な要素だ。

さて、具体的にアイコンを付けようなどという発想に行き着いたきっかけはこちらのサイト。
ateitexe.com

アイコンの話が出てくるわけではないのだけど、説明にいろいろと可愛らしいイラストが添えてあり、読んでいて楽しい。
これまで私は説明のための図解をすることはあっても、ユーザーを楽しませるためという観点でイラストを書いたことは無かった。

そうだ!イラストだ!

と思い立ったとき、たまたまユーザーフォームのデザインを考えていたのでその2つが結びついた感じ。
それで、「よし、アイコンを付けよう。」となった。

なんでまた桜なのかというと、アイコンを作るにあたってとりあえず適当な画像が手元にないので、オートシェイプで済ませようと書き始めたところ、昼間ジュンク堂でたまたま立ち読みした本に、オートシェイプで桜の花びらを描く方法が載っていたので。

絵心がなくてもできる Wordで素敵なお絵描き

絵心がなくてもできる Wordで素敵なお絵描き

花びらの特徴的な形は一見難しそうに見えるけど、実はハートを挿入して頂点を上にずらすだけのもの。超簡単!たーのしー!
f:id:t-hom:20170212013144p:plain

それで桜を描いてそれに合うようにラベルでヘッダーに色をつけて、それに合う色は、、とやってるうちに気づいたら完全に女子だった。不覚。。

実際にアイコンを付ける方法

さて、アイコンを付けようと思ったはいいが、ひとつ困ったことがある。

基本的にはUserFormにImageコントロールを置いてLoadPictureする感じなんだけど、その画像は外部から持ってこなきゃいけない。するとExcelファイル単体で動作しなくなるので配布に難がある。

そこで、隠しシートに張り付けた画像を読み込むことを思いついた。ただ直接シートからLoadPictureはできないらしく、どうしても一回保存する必要がある。

Excelには幸い環境変数を取得するEnviron関数があるので、Temporaryフォルダを取得してそこに保存するようにしよう。

ここでまた技術的な課題があって、シェイプって直接保存できないんだ。
まぁ、いろいろ調べてたら、ChartObject(つまりグラフ)はExport命令でビットマップに書き出せるらしい。

何もデータを指定せずにグラフを挿入すると空の枠だけできるので、
f:id:t-hom:20170212013841p:plain

縦横比をそろえてからシェイプを張り付ける。
f:id:t-hom:20170212014142p:plain

グラフは標準で枠のサイズにあわせて中身が伸び縮みするので、最初に比率を合わせておかないとぐちゃっとなる。

それからグラフツールのレイアウトタブからグラフ名を「SakuraIcon」としておこう。
f:id:t-hom:20170212014704p:plain

最後にシート名を「Images」として準備完了。
最終的にシートは非表示にすれば良いけど、検証段階では表示させておく。

次にフォームをデザインしていく。

基本形はこちらで紹介したので説明を割愛。
thom.hateblo.jp

今回重要なのはImageコントロール

まずはフォームのアイコン表示位置に配置する。
今回説明用にイメージコントロールの背景色は黒にしたが、どのみち画像が入るので何色でも良い。
f:id:t-hom:20170212015438p:plain

それから今回イメージコントロールに設定するプロパティは以下の2つ。
f:id:t-hom:20170212015923p:plain

アイコンに枠線が入らないようにBorderStyleを0-fmBorderStyleNoneに設定し、画像が切れずにイメージコントロールに収まるようにPictureStyleModeを1-fmPictureStyleModeStretchに設定しておく。

最後にフォームにコードを書く。

Private Sub UserForm_Initialize()
    Dim chartObj As ChartObject
    Set chartObj = Sheets("Images").ChartObjects("SakuraIcon")
    chartObj.ShapeRange.Fill.ForeColor.RGB = Label1.BackColor
    chartObj.Chart.Export Environ("temp") & "\SakuraIcon.bmp"
    Image1.Picture = LoadPicture(Environ("temp") & "\SakuraIcon.bmp")
End Sub

まずImagesシートからSakuraIconグラフオブジェクトをchartObj変数に代入し、背景色をラベル1(今回はヘッダーのラベルがlabel1)と同じに設定している。こうするとヘッダーラベルの色を変更しても自動で画像の背景色が合うので桜の背景が透過的に見える。

次にグラフオブジェクトをテンポラリーフォルダーに保存し、それを読み込んでいるだけ。

bmpファイルを作る際にはグラフのサイズで出力されるため、実際に利用する際はImagesシートに置くグラフはアイコンと同じくらいのサイズまで縮小しておくと良い。ディスク容量の消費が減るというメリットもあるが、サイズが小さいほうが読み込み書き込み共に高速に行える。

Officeに用意されたImageMSOを利用する手も

さて、アイコンを利用したいだけなら自分で作らなくともImageMSOを利用する手もある。

コードを以下のように書き換えると、

Private Sub UserForm_Initialize()
    Image1.Picture = Application.CommandBars.GetImageMso("HappyFace", 80, 80)
End Sub

こんな感じで殺センセスマイリーが表示される。
f:id:t-hom:20170212022027p:plain

参考にしたのは以下のサイト。
www.ka-net.org

紹介されているのはボタンに表示させるコードだけどオブジェクトブラウザで調べたところボタンのPictureとイメージコントロールのPictureはどちらも同じ型だったのでそのまま流用できた。

ただこの方法だとOffice2010とOffice2013では見え方が違ってくる。
それによく見ると四隅に白色の背景が見える。つまりImageコントロールに読み込むと透過処理が出来ないってことかな。
手軽にアイコンを利用できる点はよさげなので、適宜活用していきたい。

プログラミングの入門に必要なのは「おお、すげー!動いた!」という体験。小難しいことは後回し。

こちら、最近たまたま昼休みに書店に立ち寄る機会があり、ふと手に取った書籍。

アイディアを実現させる最高のツール プログラミングをはじめよう

アイディアを実現させる最高のツール プログラミングをはじめよう

ターゲット読者はプログラミングに興味はあるけどやったことがない方。具体的なコードの話はほとんど出てこなくて、プログラミングの楽しさ・面白さを語った本。

自分はまぁターゲットからは外れてるんだけれど、プログラミングが「つまらなさそう」な理由という項目が目につき、パラパラ読んでると面白そうなのでそのまま買って帰った。

ちょうど先ほど読み終えたのだが、この本はとても大事なことを思い出させてくれた。
それは、自分がどうやってプログラミングに入門したのかということ。私も昔はコピペプログラマーだった。プログラマーと呼ぶのもおこがましい。。コピパー?

最近では自分が入門者だった頃の気持ちも忘れかけており、すっかり上級者ヅラをして「基礎がいかに重要か」なんてことをドヤ顔で吹聴しまわってるんだけど、入門者にとってみたら基礎なんてどうでもよくて、とにかく早く、動くもの・面白いものが作りたいんだよね。

(なんだかよくわからんけど)できた!動いた!すげー!」

やっぱ、ここからだろう。入門は。

変数宣言なんて後回し。変数名も適当でいい。力技?どんとこい!
入門以前に、小難しい説明で挫折してしまったら意味ないもんな。

ひょっとして将来その人は素晴らしいコードを書くかもしれないのに、そんなつまらないことで芽を摘んでしまったら勿体ない。

そんなことは入門してから考えたら良い。
おぼろげながらプログラミングというものが分かってきたら、そのとき改めて考えなおそう。

ただしこれだけは伝えておく必要がある。業務でミスできないコードを書くときは、きちんと変数宣言して、型にも気を配って、意味の分かるちゃんとした変数名をつけよう。

あ、あと今回書いたのは「入門以前~入門者」であって、「初心者」ではない。
上手か下手かは別として簡単なプログラムを自力で作れるようになったら、それはもう入門者ではない。

入門者を卒業したら、改めて基礎から学びなおすべし。

ちなみに、私もプログラミングの魅力を語った記事を書いてるので、これから初めてみようかなって方は是非読んでみて。
thom.hateblo.jp

VBA クラスモジュールを使ってセル内の文字を簡単に色づけ

f:id:t-hom:20170207200918p:plain

VBAでセル内のテキストの個別の文字に色をつけるのはわりに面倒くさい。

たとえばこんな風に、着色したいとしよう。
f:id:t-hom:20170207201819p:plain

上のテキストを実現するには、以下のコードを書けば良い。

Sub hoge()
    Sheet1.Range("A1").Value = "Red, Green, Blue"
    Sheet1.Range("A1").Font.Color = vbBlack
    Sheet1.Range("A1").Characters(1, 3).Font.Color = rgbRed
    Sheet1.Range("A1").Characters(6, 5).Font.Color = rgbGreen
    Sheet1.Range("A1").Characters(13, 4).Font.Color = rgbBlue
End Sub

ここで面倒なのが、Charactorsプロパティに指定する文字数。
「何文字目から、何文字を」という指定をしないといけないけど、頭がこんがらがる。

これ、もう少しなんとかならんかな。。

というわけで、クラスモジュールを使って少し楽にカラフルな文字列を作れるようにしてみた。

作り方

クラスモジュールを挿入し、モジュール名を「ColorfulStringObject」と名づける。
コードはこちら。

Private Type ColorText
    TextPart As String
    ColorPart As XlRgbColor
End Type
Private colorTextArray() As ColorText

Private Sub Class_Initialize()
    ReDim colorTextArray(0)
End Sub

Sub AddText(txt As String, Optional col As XlRgbColor = rgbBlack)
    colorTextArray(UBound(colorTextArray)).ColorPart = col
    colorTextArray(UBound(colorTextArray)).TextPart = txt
    ReDim Preserve colorTextArray(UBound(colorTextArray) + 1)
End Sub

Function GetText()
    Dim ret As String
    Dim i As Long
    For i = 0 To UBound(colorTextArray) - 1
        ret = ret & colorTextArray(i).TextPart
    Next
    GetText = ret
End Function

Sub WriteToCell(r As Range)
    r.Value = GetText
    Dim location As Long: location = 1
    For i = 0 To UBound(colorTextArray) - 1
        r.Characters(location, Len(colorTextArray(i).TextPart)) _
            .Font.Color = colorTextArray(i).ColorPart
        location = location + Len(colorTextArray(i).TextPart)
    Next
End Sub

準備はこれだけ。
このクラスを作るにあたって工夫した点として、クラス内部にPrivateのユーザー定義型「ColorText」を宣言し、それを配列に入れているところ。通常クラス内にPublicなユーザー定義型は宣言できないが、Privateなら問題ない。

ユーザー定義型はコレクションに追加できないのが残念だが、コレクションを使いたいだけのために外部にオブジェクトを作るのも面倒なので、ワンモジュールで完結するようにユーザー定義型の配列にした。

使い方

先ほどのRed, Green, Blueを表示させるには、標準モジュール等に以下のように書く。

Sub ColorRGB()
    Dim colorfulString As ColorfulStringObject
    Set colorfulString = New ColorfulStringObject
    colorfulString.AddText "Red", rgbRed
    colorfulString.AddText ", "
    colorfulString.AddText "Green", rgbGreen
    colorfulString.AddText ", "
    colorfulString.AddText "Blue", rgbBlue
    colorfulString.WriteToCell Sheet1.Range("a1")
End Sub

AddTextメソッドに文字列と色を渡すと内部でColorText型の配列に保管される。
つまり、文字列全体を書いてから位置指定で着色するのではなく、最初からこの文字を赤で、この文字を緑でという風に追加していくのだ。
最後にWriteToCellメソッドにRangeを渡すと、そのRangeに実際にカラーで書き込まれる仕組み。

注意点として、VBAではRangeのValueプロパティを触ると色がリセットされてしまう。
そのためAddTextでは直接セルに書かず、最後にWriteToCallを呼ぶ仕様とした。

今回引数としてxlRgbColor列挙型を使用してみた。これは過去に以下の記事で紹介したもの。
thom.hateblo.jp

プロシージャの引数として列挙型を指定してやると、呼び出す側で入力ヒントが出るので便利。
f:id:t-hom:20170207203153p:plain

列挙型の実態はLongなのでRGB関数で作成した色や、vbのcolor定数(vbRedなど)も指定できる。

以下、別のサンプル。

■ランダムな色でHello, VBA!!を表示する。
f:id:t-hom:20170207203352p:plain

Sub RandomColorHelloVBA()
    Const MESSAGE = "Hello, VBA!!"
    Dim colorfulString As ColorfulStringObject
    Set colorfulString = New ColorfulStringObject
    Dim i As Long
    For i = 1 To Len(MESSAGE)
        Dim r As Byte, g As Byte, b As Byte
        r = WorksheetFunction.RandBetween(0, 255)
        g = WorksheetFunction.RandBetween(0, 255)
        b = WorksheetFunction.RandBetween(0, 255)
        colorfulString.AddText Mid(MESSAGE, i, 1), RGB(r, g, b)
    Next
    colorfulString.WriteToCell Sheet1.Range("a2")
End Sub

SQLの色分け
f:id:t-hom:20170207203443p:plain

Sub ColorSQL()
    Dim colorfulString As ColorfulStringObject
    Set colorfulString = New ColorfulStringObject
    colorfulString.AddText "select", rgbBlue
    colorfulString.AddText " * "
    colorfulString.AddText "from", rgbBlue
    colorfulString.AddText " people_table "
    colorfulString.AddText "where", rgbBlue
    colorfulString.AddText " age "
    colorfulString.AddText ">=", rgbMaroon
    colorfulString.AddText " 20"
    colorfulString.WriteToCell Sheet1.Range("a3")
End Sub

工夫すればRangeへの出力だけでなくHTML出力なんかも作れるかと思う。

以上

VBAでテンプレートを元にHTMLコードを自動生成する

今回はVBAを利用してHTMLを生成するテクニックを紹介

題材は先日紹介した、参照設定とCreateObjectの対応リスト - You.Activate
thom.hateblo.jp

このページはご覧いただくとわかるように、項目名は同じで内容だけ異なるものが複数回出てくる。
f:id:t-hom:20170206031011p:plain

ひとつのオブジェクトの紹介は以下のHTMLで構成されている。

<h3>ファイルシステムオブジェクト</h3>
<dl class="ProgIDList">
<dt>説明</dt><dd>ファイル・フォルダの生成・移動・削除やテキストファイルの生成、読み込みなどに使用</dd>
<dt class="fl">ProgID</dt><dd>Scripting.FileSystemObject</dd>
<dt class="fl">参照設定名</dt><dd>Microsoft Scripting Runtime</dd>
<dt class="fl">ライブラリ名</dt><dd>Scripting</dd>
<dt class="fl">オブジェクト名</dt><dd>FileSystemObject</dd>
<dt>アーリーバインディング書式</dt>
<dd class="code"><pre class="brush:vb toolbar:false">
    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
</pre></dd>

<dt>レイトバインディング書式</dt>
<dd class="code"><pre class="brush:vb toolbar:false">
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
</pre></dd>

これをバカ正直にコピー&ペーストで編集しても良いのだけれど、いかんせん効率が悪い。
ということで、これもテンプレートを作ってVBAでやってしまおう。

※本来はDBにデータを格納してPHPで動的にページを生成するのがセオリーだが、たかだか1ページのために仕組みを作るのも面倒だしこれくらいなら得意のVBAで良いかなと。

まず、シートはこんな感じ。
f:id:t-hom:20170206032220p:plain

薄い黄色で塗ってあるのがテンプレートで可変項目は$$$としている。
その右がデータ部で、1列がひとつのオブジェクト紹介。右へ右へとどんどんデータが続くイメージ。

ふつうはデータ方向は下なんだけど、HTMLのテンプレートは縦に書きたかったのでやむなく。
※もっとデータが多ければ、可変項目を「$$1$$」などとナンバリングしたテンプレートを別シートに作り、データは1行1レコードとする方法もある。

コードは以下の通り。シートモジュールに直接貼り付けて実行する。

Option Explicit
Sub HTMLOutput()
    Const MAX_ROW = 19
    Const START_COLUMN = 3
    Const END_COLUMN = 5
    Dim template: template = Range("B1:B" & MAX_ROW).Value
    
    Dim j, i
    For j = START_COLUMN To END_COLUMN
        Dim data: data = Range(Cells(1, j), Cells(MAX_ROW, j)).Value
        For i = 1 To MAX_ROW
            Debug.Print Replace(template(i, 1), "$$$", data(i, 1))
        Next
    Next
End Sub

実行するとイミディエイトウインドウにHTMLコードが生成されるので、あとは切り取ってエディタに貼り付ければ完成。
f:id:t-hom:20170206033502p:plain

最大行、開始列、終了列はハードコーディングしてるので使用時は定数を変更する必要あり。自動取得も簡単だけれど、今回は使い捨てマクロなのでそこは適当に。。

やってることは単純で、テンプレート部とデータ部をそれぞれ別の二次元配列に入れ、あとは1行ずつ$$$をリプレースしながらイミディエイトウインドウに出力している。

ちなみにイミディエイトウインドウは最大200行までしか出力できないので、一気に大量のデータをさばきたいときは変数に入れて最後にクリップボードに送るか、テキストファイルとして出力するなどの工夫が必要。まあ本格的にデータ扱うなら、PHP等で仕組み化した方が良いと思うが。

上記マクロで使っているセル範囲を配列に転記するテクニックはこちらに詳しく書いた。
thom.hateblo.jp

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。