SE_BOKUのまとめノート的ブログ

SE_BOKUが知ってること・勉強したこと・考えたことetc

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

f:id:arakan_no_boku:20190307220715j:plain

今回は、EXCELのセルに入力した文字を個別(1セルあたり1ファイル)の画像ファイルに保存するツールを作りました。

GitHubにおいてます。

github.com

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

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

シートとコード表示に保護をかけてます。 

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

 

使い方です。

セル「A3」(文字列)に画像にしたい文字を入力します。

セル「B3」(対象最終行)に4から83までの任意の数字を入力します。 

すると、A3に入力した文字を、1行11文字×B3に入力した数のフォントやサイズでバリエーションをつけて表示します。

(最大で83なので、11文字✕83行・・880のバリエーションということです)

f:id:arakan_no_boku:20170903213032j:plain

保存先フォルダ名にパスを「¥」を最後の文字にして入力します。 

そして「実行」ボタンを押します。

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

たとえば、開始番号に「1」を入力して、対象最終行に「83」を入力すると、880パターンの画像ファイルを「1.jpg」から「880.jpg」まで作成します。

f:id:arakan_no_boku:20170903214621j:plain

セルに表示できる文字なら何でも画像にできます。 

例えば、顔文字とか。

f:id:arakan_no_boku:20170903221324j:plain

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

f:id:arakan_no_boku:20170903221516j:plain

 

これは。機械学習の学習用データを生成する目的でつくりました。 

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

サイズを揃えるのは「Ralpha」みたいなアプリケーションを使えばすぐにできますし。

forest.watch.impress.co.jp

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

f:id:arakan_no_boku:20170903215346j:plain

今回はモノクロの28×28のサイズにします。 

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

f:id:arakan_no_boku:20170903215854j:plain

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

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

 

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ファイルにしているだけです。

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

変数名も適当です。 

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

ではでは。