【指定したフォルダ内の画像を一括でシートに表示する】【エクセル2013,VBA】
書類を作成する際に複数の画像をシートにまとめたいときのためのコード。
以下概略
ダイアログボックスで画像の入っているフォルダを選択
↓
拡張子を指定
↓
選択フォルダ内の指定された拡張子の画像がシートに貼り付けられる。
以下コード
=========================================================
Sub 画像取得v1()
'指定フォルダの画像ファイルをシートに集める。メインコード
Dim i As Long, FP As String, FN As String, SN As String, fso As Object, SaPath As String, filet As String
Application.ScreenUpdating = False
'セルサイズの調整。セルの大きさを変えたい場合はここを変更する。
Columns("A:A").ColumnWidth = 3
Columns("B:C").ColumnWidth = 15
Columns("D:D").ColumnWidth = 50
'カラムA→連番、B→ファイル名、C→作成日、D→画像
Range("A1") = "No"
Range("B1") = "FileName"
Range("C1") = "作成日"
Range("D1") = "画像"
'画像が入っているフォルダ（FN）を選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "画像が入っているフォルダを選択してください。"
If .Show = -1 Then
FN = .SelectedItems(1)
Else 'キャンセル
Exit Sub
End If
End With
'画像の拡張子を選択
filet = InputBox("拡張子を入力してください", "", ".JPG")
tst = ActiveWorkbook.Name
SN = ActiveSheet.Name
Set fso = CreateObject("Scripting.FileSystemObject")
'拡張子確認ルーチンを呼び出す
Call checkFileJPG(fso, FN, SN, filet, 2)
'見やすく書式を整える
Columns("A:D").Select
Selection.AutoFilter
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Application.ScreenUpdating = True
MsgBox "完了"
End Sub
Sub checkFileJPG(fso As Object, FilePath As String, SN As String, filet As String, totalN As Long)
'拡張子確認ルーチン。再帰式でフォルダをどんどん深くもぐってファイルが指定された拡張と同じか確認していく。
On Error Resume Next
Dim TargetFile As Object, TargetFile2 As Object, CellHight As Long
'セルの高さ設定値。画像の大きさは「セルの高さ-5」。画像の大きさを変えたい場合はここを変える。
CellHight = 165
'フォルダ内のファイルの拡張子をひとつづつチェックしていく。
For Each TargetFile In fso.getfolder(FilePath).Files
'もし拡張子が一致したら。大文字小文字関係なし設定。
If UCase(Right(TargetFile.Name, Len(filet))) = UCase(filet) Then
'セルの高さを調整
Sheets(SN).Range(Cells(totalN, 4), Cells(totalN, 1)).RowHeight = CellHight
'ファイル名等の情報を入力
Sheets(SN).Cells(totalN, 1) = totalN - 1
Sheets(SN).Cells(totalN, 2) = TargetFile.Name
Sheets(SN).Cells(totalN, 3) = TargetFile.datecreated
'画像を貼り付けを呼び出す
Call 画像挿入v1("D" & totalN, TargetFile.Path, SN, CellHight - 5)
'total→貼り付ける行
totalN = totalN + 1
End If
Next
'サブフォルダがあれば再帰式でフォルダをどんどん深くもぐっいく
For Each TargetFile2 In fso.getfolder(FilePath).SubFolders
Call checkFileJPG(fso, TargetFile2.Path, SN, filet, totalN)
Next
End Sub
Sub 画像挿入v1(CellA As String, myFileName As String, SN As String, Thight As Single)
'画像を貼り付け
Dim myShape As Shape, TH As Single, TW As Single
On Error Resume Next
'指定されたセルの左上に貼り付け
Set myShape = Worksheets(SN).Shapes.AddPicture( _
Filename:=myFileName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Sheets(SN).Range(CellA).Left, _
Top:=Sheets(SN).Range(CellA).Top, _
Width:=0, _
Height:=0)
'画像の大きさをセルの高さより若干小さくする。縦横比はそのまま。
With myShape
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
TH = .Height
TW = .Width
.Height = Thight
.Width = TW * Thight / TH
End With
End Sub
