Excel / Jon Juan
システムのバージョンアップに伴ない、アプリケーションのテストを実施する事になりました。
この作業は動作確認をしつつ、ひたすら画面のキャプチャーを取得してExcelに貼りつけるという単純な作業になります。とはいえ、完全に自動化して実施できるほど簡単でもなく、何度もやる必要のない仕事です。
そこで、すこしでも楽をしようとExcelのアドインを使って、キャプチャーした複数の画像ファイルをエクセルに一括で貼りつけるアドインを使用しました。
アドインを使うと、提出用のExcelブックをマクロで汚すことなく、マクロと同じように作業を自動化できます。
もっともアドインを作って登録するまでが、かなり煩雑な手順が必要なのですが…。
ポイントとしては最近のExcelだと画像を挿入すると、画像そのものが貼られるのではなく、画像のリンクが貼られてしまうので、そのままでは提出用としては使いずらいものとなります。そこで一度貼りつけた画像をクリップボードにコピーして、再度同じ場所にペーストする事で、画像がリンクになる事を回避しています。(Excel上では後からではリンクを内部画像に変換できないようです)
元ネタはどこかの掲示板で取得したマクロです。先人の努力に感謝です。
以下にそのソースを掲載します。
Sub 複数の画像を挿入()
'
' 複数の画像を挿入 Macro
'
' Keyboard Shortcut:
'
Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture
' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可）", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub
' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)
' 貼り付け開始セルを選択
'Range("C5").Select
' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))
'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
' .Height = ActiveCell.MergeArea.Height
.ScaleHeight 0.5, msoTrue
.ZOrder msoSendToBack
End With
ActiveCell.Select
'Set ActiveCell.Width = PIC.ShapeRange.Width
Dim row, col As Integer
row = ActiveCell.row
col = ActiveCell.Column
ActiveCell.ColumnWidth = PIC.ShapeRange.Width / 6
PIC.CopyPicture
PIC.Delete
ActiveSheet.Paste
Dim count As Integer
count = ActiveSheet.Shapes.count
ActiveSheet.Shapes(count - 1).ZOrder msoSendToBack
' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル]
'ActiveCell.Offset(5).Select
ActiveCell.Offset(0, 2).Select
Set PIC = Nothing
Next i
' 終了
Application.ScreenUpdating = True
MsgBox i - 1 & "枚の画像を挿入しました", vbInformation
End Sub
' バブルソート（文字列）
Private Sub BubbleSort_Str( _
ByRef Source As Variant, _
Optional ByVal SortAsc As Boolean = True, _
Optional ByVal Compare As VbCompareMethod = vbTextCompare)
If Not IsArray(Source) Then Exit Sub
Dim i As Long, j As Long
Dim vntTmp As Variant
For i = LBound(Source) To UBound(Source) - 1
For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
If StrComp(Source(IIf(SortAsc, j, j + 1)), _
Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
vntTmp = Source(j)
Source(j) = Source(j + 1)
Source(j + 1) = vntTmp
End If
Next j
Next i
End Sub
' ある一つのサブフォルダについての処理
Private Function importImagesFromOneSubDir(sub_dir, y, root_dir)
'MsgBox sub_dir.Name
' このフォルダ内の画像をすべて列挙
file_name = Dir(sub_dir & "\*.*")
Do While file_name <> ""
' このファイルの拡張子を調べる
If isImageFile(file_name) Then
' 画像であれば，取り込んで次の行へ
importImageFile file_name, y, root_dir, sub_dir
y = y + 1
End If
' 次のファイルを取得
file_name = Dir()
Loop
' 現在の行を返す
importImagesFromOneSubDir = y
End Function
' 画像ファイルかどうか，拡張子で判定する
Private Function isImageFile(file_name)
' ピリオドは後ろから何文字目か
pos_period = InStrRev(file_name, ".")
If pos_period > 0 Then
' 拡張子を切り出し
file_ext = LCase(Mid(file_name, pos_period + 1))
' 画像の拡張子か？（小文字で指定可）
If _
file_ext = "jpg" Or _
file_ext = "jpeg" Or _
file_ext = "bmp" Or _
file_ext = "gif" Or _
file_ext = "png" _
Then
' 画像であると判定
ret = True
Else
ret = False
End If
Else
ret = False
End If
' http://officetanaka.net/excel/vba/tips/tips57.htm
isImageFile = ret
End Function
' ある一つの画像ファイルをシート中に取り込む
Private Sub importImageFile(file_name, y, root_dir, sub_dir)
file_path = sub_dir & "\" & file_name
' 一列目にはサブフォルダ名を
ActiveSheet.Cells(y, 1).Value = sub_dir.Name
' 二列目には画像を
ActiveSheet.Cells(y, 2).Select
Set myShape = ActiveSheet.Shapes.AddPicture( _
fileName:=file_path, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=Application.CentimetersToPoints(6), _
Height:=Application.CentimetersToPoints(1))
' http://www.moug.net/tech/exvba/0120020.html
' http://www.moug.net/tech/exvba/0070012.html
' この行高を自動調整
Cells(y, 1).RowHeight = Application.CentimetersToPoints(1)
End Sub
Sub picIns(ByVal r As Range, _
ByVal s As String, _
ByVal W As Single, _
ByVal H As Single)
With ActiveSheet.Pictures.Insert(s).ShapeRange
If (W > 0) And (H > 0) Then
.LockAspectRatio = msoFalse
.Width = W
.Height = H
ElseIf W > 0 Then
.Width = W
ElseIf H > 0 Then
.Height = H
End If
.Left = r.Left
.Top = r.Top
End With
End Sub