t-hom’s diary

主にVBAネタを扱っているブログ…とも言えなくなってきたこの頃。

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だけ出力される。
イミディエイトはこんな感じ。
f:id:t-hom:20170303234345p:plain

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

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である。
f:id:t-hom:20170302213958p:plain

次に、もう一つファイル型のアイコンを選ぶ。

今回はCustomPageNumberBottomGallery.bmpをチョイスした。
f:id:t-hom:20170302214225p:plain

この2つのそれぞれのピクセルを取得し、輝度と色相が似通った箇所だけ抜き出すと、このようになる。
f:id:t-hom:20170302214411p:plain

※細かい話をすると実際にはこんな感じになるのだけど、ややこしいので のっぺらぼうになることにして話を進める。
f:id:t-hom:20170302214617p:plain

すると、この のっぺらぼうが、類似ファイルを探す際のフィルターになる。
f:id:t-hom:20170302214411p:plain

あとは各ファイルをループで回しながらフィルターと同じ箇所のピクセルを比較し、一致率が一定以上のものを類似画像と判定すればよい。

注意点は、白に近いほど輝度の高いピクセルは無視すること。
でないと余白も比較対処に入ってしまい、大量の類似画像がでてくる。

作り方

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

実行結果

このとおり、類似画像が集まってきた。
f:id:t-hom:20170302220400p:plain

ただ一部、端が折れてないものも混じってくる。
f:id:t-hom:20170302220448p:plain

類似画像選り分けマクロの基準値を70から60に下げて実行してみると、さらに多くのファイルが取得できたが、関係ないアイコンが混じる確率も上昇する。

            If base.EvalSimilarityScore(.Self) > 60 Then
                .MoveFile 振分け先
            End If

さて、一応類似画像を取得できるようになったものの、取れてない画像も相当数ある。
以下は最初の基準でとれなかった画像。
f:id:t-hom:20170302221344p:plain

それもそのはずで、人間はファイルアイコンというカテゴリで一括りできてもコンピューターだと少しでもズレてると難しい。
f:id:t-hom:20170302221929p:plain

そこで改めてExcelのファイルアイコンを基準にパワポのファイルアイコンをフィルター作成用に用いて実行したところ、Office系のファイルアイコンがごっそりとれた。
f:id:t-hom:20170302221644p:plain

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

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

結果はこのとおり。
f:id:t-hom:20170226113734p:plain
※セル幅・ズームは手でいじってます。

でもなんか普段みるやつと違う。

↓普段みるやつ
f:id:t-hom:20170226113848p:plain

こうか?

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

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

惜しい。
もう一度普段みるパレットをよく確認してみると、どうやらメイン領域で色相・彩度を扱っていて、隣のバーで明度を扱ってるようだ。
f:id:t-hom:20170226114522p:plain

ちなみに定数を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

f:id:t-hom:20170226115129p:plain
おおっ!

ん?

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

なにこれwww

気になるけど無視して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つ。
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 | Microsoft Docs

まず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追記

サイトに表をアップしたので、こちらもご参照ください。
https://www.thom.jp/vbainfo/xlrgbcolor.html

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コントロールに読み込むと透過処理が出来ないってことかな。
手軽にアイコンを利用できる点はよさげなので、適宜活用していきたい。

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