"BOKU"のITな日常

62歳・文系システムエンジニアの”BOKU”は日々勉強を楽しんでます

各セルの内容を個別の画像ファイルに保存するVBAツールを作る/EXCELの小ネタ

今回は、EXCELのセルに展開した文字のイメージを、1セル1画像ファイルに保存する簡単なツールを作りましたという話です。

f:id:arakan_no_boku:20190307220715j:plain

 

こういう使い方を想定したツールです

 

画面のイメージはこんな感じ。

f:id:arakan_no_boku:20170903213032j:plain

 

セル「A3」(文字列)に画像にしたい文字を入力して、セル「B3」(対象最終行)に4から83までの任意の数字を入力します。 

そうすると指定した数だけ、セルにその文字のバリエーションが表示されます。

文字のバリエーションは、単純にフォントやサイズ、あとセルの中での表示位置などでつけてます。

そして「実行」ボタンを押すと、セル「E3」(開始番号)から連番でファイル名を生成しながら、セルに表示した文字のイメージを画像ファイルに保存します。 

たとえば、開始番号に「1」を入力して、880パターンの画像を生成すると、ファイル名は「1.jpg」から「880.jpg」まで連番で作成されるわけです。

とりあえず、最大で1行11文字✕83行の880ファイルの画像ファイルを上限にしていますが、880以上の連番のファイルを作りたければ、880.jpgまで生成してから、次に開始番号「881」から始めればいい・・とまあ、そんな仕様です。

 

そのファイルは、セル「F3」(保存先フォルダ)で指定した場所に作成されるので、

フォルダ名は必「¥」で終わるようにする必要があります。 

 

f:id:arakan_no_boku:20170903214621j:plain

 

なんでこんなツールを作ったのか?

 

Neural Network Consoleで遊び始めた時に、手書き数字データのMNISTには飽きたけど、他にモノクロで28×28の適当な画像を見つけることができなかったからです。

なので。

ないなら・・自分で作ろう・・ということで用意したのが、このツールです。

悲しいかな。

生成した画像のサイズをピッチリ28×28にそろえる・・ところまでできてません。

サイズを揃えるのは、すでに、素晴らしいツールがいっぱいあるので、それを使えばいいやと思ってたので、そこまで凝ってないというのが本音ですが。 

 

Ralphaでサイズをそろえる

 

サイズをそろえるとき、自分が愛用しているのは、「Ralpha」です。

forest.watch.impress.co.jp

 

なので、説明自体は「Ralpha」でします・・が、別に、他に慣れたツールがあれば、そちらを使っても全然問題ないと思います。 

Ralphaを立ち上げて、先程生成した画像ファイルをドロップします。

f:id:arakan_no_boku:20170903215346j:plain

 

 デフォルトのINPUTの設定を使えるようにしたいので、今回はモノクロの28×28のサイズにします。 

幅と高さに28を入力し(28✕28にするとき)、リサイズにチェックをつけて、実行ボタンを押します。

f:id:arakan_no_boku:20170903215854j:plain

 

そうすると、画像ファイルのフォルダに、resizeというフォルダができて、その下にリサイズされたファイルが生成されます。 

あとは、resizeという名前を、正解ラベルに変更すれば、OKです。 

 

おまけで「顔文字」画像とかやってみたり

 

デフォルトでは半角英数字1文字を想定して作ってますが、セルに表示できる文字なら何でも画像にできます。 

もちろん、文字のサイズにあわせて、セルの幅や高さを変えて表示できるようにしないといけないですけど、例えば、顔文字とか。

f:id:arakan_no_boku:20170903221324j:plain

 生成された画像はこちら。

f:id:arakan_no_boku:20170903221516j:plain

意外と面白いですね。 

 

 

 

ツールのVBAソース

 

実のところ、マクロも大したことはしてません。 

解説は特にしませんが、たったこれだけなので、全文載せておきます。

Sub image_save()
     Dim fpath, Fname, sheet1_name, sheet2_name, sheet3_name As String
     Dim tobj, ACWidth, ACHeight, Tcht
     Dim r, c, fn, lastRow As Long

     sheet1_name = "moto"
     sheet2_name = "work"

     fpath = Worksheets(sheet1_name).Range("F3").Text
     Application.ScreenUpdating = False

     Worksheets(sheet1_name).Select
     fn = Worksheets(sheet1_name).Range("E3").Value
     lastRow = Worksheets(sheet1_name).Range("B3").Value

     For r = 4 To lastRow
          For c = 1 To 11
                Worksheets(sheet1_name).Cells(r, c).CopyPicture _
                               Appearance:=xlScreen, Format:=xlPicture
                Worksheets(sheet2_name).Paste

                For Each tobj In Worksheets(sheet2_name).Shapes
                       If tobj.Type = 13 Then
                                tobj.CopyPicture
                                Fname = fn
                                ACWidth = tobj.Width
                                ACHeight = tobj.Height

                                Set Tcht = Worksheets(sheet2_name).ChartObjects.Add(0, 0, ACWidth * 0.8, ACHeight * 0.8).Chart
                               Tcht.Paste

                               Tcht.Export Filename:=fpath & Fname & ".jpg", filtername:="JPG"
                               Tcht.Parent.Delete 
                                tobj.Delete
                                fn = fn + 1
                           End If

                      Next
               Next c
           Next r
           Application.ScreenUpdating = True
End Sub

 

Excelのセルを、一旦ワークシートに画像(picture)で貼り付けて、それをグラフに変換して、グラフのエクスポート機能を使って、JPGファイルにしているだけです。

自分用の使い捨てツールのつもりだったので、かなり雑に書いてます。 

変数名も適当ですし。 

なので、その辺のつっこみはやめてくださいね(笑) 

 

ツールのダウンロードできるようにしてます

 

 

ツールは、一応、GitHubにおいてます。

興味があればどうぞ。

github.com

大量学習用画像一括生成.xlsmというファイルです。 

ZIPでダウンロードして解凍してください。 

ツールは、ExcelVBAで作ってます。 

Excelがインストールされている環境でないと使えません。 

動作確認は、WindowsのExcel2007とExcel2010でやってます。 

なお、シートは保護をかけてます。 

パスワードは特にかけてないですけど。 

一応、コード表示にも保護をかけてます。 

上に全部書いているので、隠す必要はないのですが、マクロを修正してまで使いたいと考える人がいるとも思えないので、まあ、いいかな・・と。

問題あったら、ごめんなさい(笑)

ではでは。