2020/01/26追記
※この記事のコードはバグだらけだったので以下の記事でデバッグしています！
エビデンス生成マクロがバグだらけだったのでデバッグしました
使い方は変わらないので、以下の記事は取扱説明書、もしくはデバッグ前の参照ソースコードとして読んでもらえると幸いです
エビデンスって取るのめんどくさいですよね
最近はテストを自動化するツールなんかもあったりするみたいですが、それでも導入できずに手動でテストをしていたり、その他の理由でエビデンスを取らなければならないという現場も少なくないのではないでしょうか
最近、VBAやGASの勉強を始めまして、エビデンスのエクセルファイルを作成する作業だけでもVBAで自動化出来ないのかと思っていたら案の定ありました。
クリップボードにある画像をエクセルに貼っていく感じですね。
ただ、これだとPCで撮ったエビデンスしか貼れません。
私のいる現場ではiOSやandroidの開発もあるので、ipadで撮ったスクリーンショットなども含めてエビデンスを作成したいと思い、勉強も兼ねて自分で作ってみました。
概要
任意のフォルダの直下にある画像ファイルの名前を読み取って、ブックの作成、シートの作成、エビデンスの貼り付けを自動で行います。
例えば、以下のように画像が保存してあるフォルダがあったとします。
このフォルダのpathを指定して、作成したいエビデンスの名前（今回はtest.xlsxとします）も指定すると、以下のようなエクセルファイルを作成します。
＜シート名：1＞
＜シート名：2＞
また、作成したエクセルファイルは画像があるpathの配下に保存されるので、マクロ実行後はこうなります。
上記にあるPNG,JPG以外にも、TIF,BMPなどにも対応しています。
画像ファイル名の-(ハイフン)より前をシート名として、シートを作成しています。
ハイフンより前の文字列が同じ画像をハイフンより後ろの文字列の順に同じシートに貼り付けます。
実際に実行するとこんな感じになります。
コード
実際に書いたコードは以下の通りです。変数名をつけるセンスが無さすぎるので、いい変数名などご教授いただける優しい方がいらっしゃいましたら是非コメントお願いします。
リファクタリングなどのご意見も大歓迎です。
Sub generate_sheet(evidence_name As String, PATH_ As String)
Dim wb As Workbook '新しいworkbookを作成
Set wb = Workbooks.Add
Dim f_name As String '挿入する画像の名前
Dim f_name_arr() As String '画像名の配列
Dim swap As String 'ソート用のスワップ
Dim i As Long 'Forループ用
Dim j As Long 'Forループ用
Dim k As Long 'Forループ用
Dim Sheet_name As String '生成するシート名
Dim ws As Worksheet 'ワークシート
Dim sheet_flg As Boolean '生成しようとするシート名と同じシートがあるかどうかのフラグ
Dim pic_exist_flg As Boolean '対象のファイルがあるかどうか判別するフラグ
Dim file_name_flg As Boolean '指定されたディレクトリ配下に保存しようとしたファイル名と同名のファイルがあるか検索
Dim pic_top As Long '挿入する画像のTop位置
Dim shp As Shape '画像を一時的に代入するshape
wb.Activate '生成したworkbookをアクティブにする
'選択したpathの配下にファイルが無かったら抜ける
f_name = Dir(PATH_ & "\*")
If f_name = "" Then
MsgBox PATH_ & "にはファイルがありません。"
Application.Quit
Exit Sub
End If
'配列にファイル名を詰める
Do
i = i + 1
ReDim Preserve f_name_arr(1 To i)
f_name_arr(i) = f_name
f_name = Dir
Loop While f_name <> ""
'ソート
For j = 1 To i
For k = i To j Step -1
If StrComp(f_name_arr(j), f_name_arr(k)) = 1 Then
swap = f_name_arr(j)
f_name_arr(j) = f_name_arr(k)
f_name_arr(k) = swap
End If
Next k
Next j
'画像を挿入する
For j = 1 To i
f_name = f_name_arr(j)
If f_name = evidence_name & ".xlsx" Then
file_name_flg = True
End If
'拡張子がtif,tiff,png,jpg.jpeg,bmpじゃなかったら飛ばす
If UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("png") Or _
UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("jpg") Or _
UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("jpeg") Or _
UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("bmp") Or _
UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("tif") Or _
UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("tiff") Then
'ファイル名に-（ハイフン）がなかったら飛ばす
If InStr(f_name, "-") <> 0 Then
Sheet_name = Left(f_name, InStr(f_name, "-") - 1) '-(ハイフン)の前の文字列をファイル名とする
pic_exist_flg = True
Else
GoTo Skip
End If
Else
GoTo Skip
End If
sheet_flg = False 'sheet_flgの初期化
'既に同じ名前のワークシートがあったらワークシートを生成しない
For Each ws In Worksheets
If ws.Name = Sheet_name Then
sheet_flg = True
Exit For
End If
Next ws
'同名のワークシートがなければ、一番後ろにワークシートを生成
If sheet_flg = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Sheet_name
pic_top = 20 '1枚目の画像は上から20px空ける
End If
'任意のワークシートに画像を挿入
With Sheets(Sheet_name)
Set shp = .Shapes.AddPicture( _
Filename:=PATH_ & "\" & f_name, _
linktofile:=False, _
savewithdocument:=True, _
Left:=20, _
Top:=pic_top, _
Width:=0, _
Height:=0)
End With
With shp
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
pic_top = pic_top + .Height + 20 '次の画像は20px空けたところに挿入する
End With
Skip:
Next
If pic_exist_flg <> True Then
MsgBox PATH_ & "には対象となるファイルがありません。"
Application.Quit
Exit Sub
End If
'最初から存在するシートを削除
Application.DisplayAlerts = False
Worksheets(1).Delete
Application.DisplayAlerts = True
'一枚目のシートをアクティブにする
Worksheets(1).Activate
If file_name_flg = True Then
MsgBox PATH_ & "に同名のエクセルファイルがあります。" & vbCrLf & "ファイル名を変えて保存してください。"
Else
'指定したファイル名でエクセルファイルを保存
wb.SaveAs _
Filename:=PATH_ & "\" & evidence_name & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
End If
'マクロを実行したエクセルファイルを閉じる
Workbooks("evidence.xlsm").Close
End Sub
Private Sub CommandButton1_Click()
'ユーザーフォームのボタンを押したらシートを生成する関数を呼び出す
Call generate_sheet(TextBox1.Text, TextBox2.Text)
Unload Me
End Sub
Private Sub UserForm_Initialize()
'ユーザーフォームが出ている間はエクセルファイルを見せない
Application.Visible = False
'ユーザーフォームのサイズ指定
Application.WindowState = xlMaximized
Me.Height = 220
Me.Width = 450
Me.Zoom = 100
End Sub
Private Sub UserForm_Terminate()
'ユーザーフォームが閉じたらエクセルファイルを見せる
Application.Visible = True
End Sub
Private Sub Workbook_Open()
'ワークシートを開いた時にユーザーフォームを出す
path_input.Show
End Sub
ユーザーフォームはこんな感じです。
FilenameのテキストボックスがTextBox1で、PathのテキストボックスがTextBox2になってます。
流れの説明
まずワークシートが開かれた時にユーザーフォームが表示されます。
Private Sub Workbook_Open()
'ワークシートを開いた時にユーザーフォームを出す
path_input.Show
End Sub
そのユーザーフォームに作成したいエクセルファイルの名前と、貼り付けたい画像が保存してあるpathを入力して「エビデンス生成」のボタンを押すと、テキストボックスからそれぞれを取得して、関数を走らせます。
Private Sub CommandButton1_Click()
'ユーザーフォームのボタンを押したらシートを生成する関数を呼び出す
Call generate_sheet(TextBox1.Text, TextBox2.Text)
Unload Me
End Sub
呼び出された関数で変数を定義するのと一緒に新しいワークブックを作成します。
Dim wb As Workbook '新しいworkbookを作成
Set wb = Workbooks.Add
Dim f_name As String '挿入する画像の名前
Dim f_name_arr() As String '画像名の配列
Dim swap As String 'ソート用のスワップ
Dim i As Long 'Forループ用
Dim j As Long 'Forループ用
Dim k As Long 'Forループ用
Dim Sheet_name As String '生成するシート名
Dim ws As Worksheet 'ワークシート
Dim sheet_flg As Boolean '生成しようとするシート名と同じシートがあるかどうかのフラグ
Dim pic_exist_flg As Boolean '対象のファイルがあるかどうか判別するフラグ
Dim file_name_flg As Boolean '指定されたディレクトリ配下に保存しようとしたファイル名と同名のファイルがあるか検索
Dim pic_top As Long '挿入する画像のTop位置
Dim shp As Shape '画像を一時的に代入するshape
指定したpathの配下にファイルがなかったら処理を終了します。
'選択したpathの配下にファイルが無かったら抜ける
f_name = Dir(PATH_ & "\*")
If f_name = "" Then
MsgBox PATH_ & "にはファイルがありません。"
Application.Quit
Exit Sub
End If
配列に指定したpath配下のファイルの名前を詰めていきます。ここではバリデーションをせずにとりあえず全部詰めます（後で使うので）。
'配列にファイル名を詰める
Do
i = i + 1
ReDim Preserve f_name_arr(1 To i)
f_name_arr(i) = f_name
f_name = Dir
Loop While f_name <> ""
後の処理の都合でファイルが名前順に並んでくれないと困るので、ソートします。（おそらくフォルダ内で名前順にソートされているとは思うのですが）
'ソート
For j = 1 To i
For k = i To j Step -1
If StrComp(f_name_arr(j), f_name_arr(k)) = 1 Then
swap = f_name_arr(j)
f_name_arr(j) = f_name_arr(k)
f_name_arr(k) = swap
End If
Next k
Next j
ソートが終わったらいよいよシートを作成しつつ、画像を貼り付けます。
ここでバリデーションと保存しようとしているエクセルファイルの名前が既に存在するものではないかのチェックを行います。
バリデーションチェックを抜けたら、シート名となるハイフンより前の文字列を取り出します。
'画像を挿入する
For j = 1 To i
f_name = f_name_arr(j)
If f_name = evidence_name & ".xlsx" Then
file_name_flg = True
End If
'拡張子がtif,tiff,png,jpg.jpeg,bmpじゃなかったら飛ばす
If UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("png") Or _
UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("jpg") Or _
UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("jpeg") Or _
UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("bmp") Or _
UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("tif") Or _
UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("tiff") Then
'ファイル名に-（ハイフン）がなかったら飛ばす
If InStr(f_name, "-") <> 0 Then
Sheet_name = Left(f_name, InStr(f_name, "-") - 1) '-(ハイフン)の前の文字列をファイル名とする
pic_exist_flg = True
Else
GoTo Skip
End If
Else
GoTo Skip
End If
ワークシートの名前をチェックし、作成しているワークシートと同名のものがなければ作成し、そのワークシートの一番上に画像を貼り付けます。
同名のワークシートがある場合はそのワークシートで貼り付けてある画像の下に新たな画像を貼り付けます。
この時にファイルがソートされていないと、画像を挿入する位置が変になるんです。
sheet_flg = False 'sheet_flgの初期化
'既に同じ名前のワークシートがあったらワークシートを生成しない
For Each ws In Worksheets
If ws.Name = Sheet_name Then
sheet_flg = True
Exit For
End If
Next ws
'同名のワークシートがなければ、一番後ろにワークシートを生成
If sheet_flg = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Sheet_name
pic_top = 20 '1枚目の画像は上から20px空ける
End If
'任意のワークシートに画像を挿入
With Sheets(Sheet_name)
Set shp = .Shapes.AddPicture( _
Filename:=PATH_ & "\" & f_name, _
linktofile:=False, _
savewithdocument:=True, _
Left:=20, _
Top:=pic_top, _
Width:=0, _
Height:=0)
End With
With shp
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
pic_top = pic_top + .Height + 20 '次の画像は20px空けたところに挿入する
End With
Skip:
Next
すべての画像を貼り終わったらその後の処理です。
まず、指定したpathの配下の画像がバリデーションでひっかかってしまった場合（画像ファイルでない、ファイル名にハイフンが入っていない）、アラートを表示させて処理を終了します。
If pic_exist_flg <> True Then
MsgBox PATH_ & "には対象となるファイルがありません。"
Application.Quit
Exit Sub
End If
一枚でも新しいワークシートが作成できているのであれば、最初からあるワークシートは不要なので、削除して1枚目のワークシートをアクティブにします。
'最初から存在するシートを削除
Application.DisplayAlerts = False
Worksheets(1).Delete
Application.DisplayAlerts = True
'一枚目のシートをアクティブにする
Worksheets(1).Activate
保存しようとしているpath配下に同盟のエクセルファイルが存在する場合は、保存は行わず、メッセージボックスを表示させます。
同名のエクセルファイルが無い場合は保存します。
その後、マクロを実行しているエクセルファイルを閉じて終了です。
If file_name_flg = True Then
MsgBox PATH_ & "に同名のエクセルファイルがあります。" & vbCrLf & "ファイル名を変えて保存してください。"
Else
'指定したファイル名でエクセルファイルを保存
wb.SaveAs _
Filename:=PATH_ & "\" & evidence_name & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
End If
'マクロを実行したエクセルファイルを閉じる
Workbooks("evidence.xlsm").Close
End Sub
やってみて
最初はvbaで別のものを作ろうとしていたのですが、触ってたらエビデンスってvbaでなんとかなんないの？っていう思いつきから作ってみた偶然の産物です。
いざ始めてみたらコーディングは1日で出来たので、vbaって意外に簡単にできるんだなっていうのが率直な感想ですね。
ただ、まだまだペーペーのエンジニアなので、色んな人からフィードバックもらいたいなと思ってQiitaに投稿してみました！
是非コメントで色々ご意見いただけると幸いです！
追記
【備忘録】Excel2010以降のVBAで画像の実体を挿入する
こちらの記事にあるように、「ActiveSheet.Pictures.Insert」だと画像がリンク貼り付けになっちゃうので、作成したエビデンスを人に渡したりすると画像が見れない！っていうとんでもないバグが見つかりました。
完全に考慮不足…
ということで、「ActiveSheet.Pictures.Insert」から「ActiveSheet.Shapes.AddPicture」に直しました。