ファイル選択ダイアログを表示し、選択したフォルダ配下の画像をすべてセル内に取り込みます。
キャプチャでは画像サイズが揃っていますが、画像サイズはそろえず、そのままの大きさで挿入します。
画像がセルの最大高さを超える場合は別シートに画像を挿入して、リンクを張ります。
シートはフォルダごとに分けるので、同じ名前でシート名が生成される場合は処理をスキップします。
Option Explicit
Private Const COL_NUMBER = 1 '採番記入列
Private Const COL_FILEPATH = 2 'ファイルパス記入列
Private Const COL_PICTURE = 3 '画像挿入列
Private Const MAX_CELL_HEIGHT = 409 'セル高さ上限
'---------------------------------------------------------------------------------------------------
'【処 理 名】初期処理
'【処理概要】初期設定を行う
'【引 数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub init()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.StatusBar = "...処理中"
End Sub
'---------------------------------------------------------------------------------------------------
'【処 理 名】終期処理
'【処理概要】終期処理を行う
'【引 数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub term()
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
'---------------------------------------------------------------------------------------------------
'【処 理 名】ImportImages：画像取り込み
'【処理概要】フォルダ内の画像をシートに張り付ける。
'【引 数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub ImportImages()
Dim folderpath As String '先頭のフォルダパス
Dim oFso As New FileSystemObject
'フォルダ選択ダイアログからフォルダパスを取得する
folderpath = GetFolderPath
If folderpath = "" Then
Exit Sub
End If
'初期処理
Call init
'画像取り込み処理
Call InsertPicturesOfAllFolders(folderpath)
'終期処理
Call term
MsgBox "取り込み完了"
End Sub
'---------------------------------------------------------------------------------------------------
'【処 理 名】フォルダパス取得
'【処理概要】フォルダ選択ダイアログを表示し、フォルダパスを取得する
'【引 数】なし
'【返 却 値】フォルダパス
'---------------------------------------------------------------------------------------------------
Private Function GetFolderPath() As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show <> -1 Then
Exit Function
End If
GetFolderPath = .SelectedItems(1)
End With
End Function
'---------------------------------------------------------------------------------------------------
'【処 理 名】InsertPicturesOfAllFolders
'【処理概要】画像取り込み
'【引 数】[I]ByVal TopPath As String：取り込み対象のフォルダパス
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub InsertPicturesOfAllFolders(ByVal TopPath As String)
Dim oFolder As Folder 'フォルダオブジェクト
Dim oFile As File 'ファイルオブジェクト
Dim listSh As Worksheet '画像を張り付けるワークシート
Dim oFso As New FileSystemObject
Dim iRow As Long '書き込み行
'フォルダオブジェクト取得
Set oFolder = oFso.GetFolder(TopPath)
'末尾にシートを挿入する
Set listSh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
'シート名を変更する。同じ名前があった場合は変更しない
Call SetSheetName(listSh, oFolder.Name)
'A1セルにディレクトリのパスを入力する
listSh.Range("A1").Value = TopPath
iRow = 4
'フォルダの全てのファイル
For Each oFile In oFso.GetFolder(TopPath).Files
'セルに画像を貼り付ける
Call InsertImage(listSh, oFile, iRow)
iRow = iRow + 1
DoEvents
Next
'フォルダ内のサブフォルダすべて処理
For Each oFolder In oFolder.SubFolders
'再帰
Call InsertPicturesOfAllFolders(oFolder.Path)
DoEvents
Next
End Sub
'---------------------------------------------------------------------------------------------------
'【処 理 名】InsertPicture
'【処理概要】画像ファイルをExcelのシート状に取り込む
'【引 数】[I]ByVal listSh As Worksheet：ワークシートオブジェクト
' [I]ByVal filePath As String：取り込む画像ファイルのパス
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub InsertImage(ByVal listSh As Worksheet, ByVal oFile As File, ByVal iRow As Long)
Dim pic As Picture '画像オブジェクト
Dim picHeight As Integer '画像の高さ
Dim newSh As Worksheet '追加したワークシートオブジェクト
Dim oFso As New FileSystemObject 'ファイルシステムオブジェクト
'採番を書き込む
listSh.Cells(iRow, COL_NUMBER).Value = "=N(INDIRECT(""R[-1]C"",FALSE))+1"
'画像ファイル名を書き込む
listSh.Hyperlinks.Add Anchor:=listSh.Cells(iRow, COL_FILEPATH), _
Address:=oFile.Path, _
SubAddress:="", _
TextToDisplay:=oFso.GetFileName(oFile.Path)
'画像ファイルではない場合はメソッドを抜ける
If Not IsImageFile(oFile.Path) Then
Exit Sub
End If
'画像を挿入する
Set pic = listSh.Pictures.Insert(oFile.Path)
'画像の位置を調整する
pic.Top = listSh.Cells(iRow, COL_PICTURE).Top + 5
pic.Left = listSh.Cells(iRow, COL_PICTURE).Left + 5
If (pic.Height + 10) <= MAX_CELL_HEIGHT Then
'セルの高さを調整する
listSh.Cells(iRow, COL_PICTURE).RowHeight = pic.Height + 10
Exit Sub
End If
'画像の高さがセル高さ上限より大きい場合は画像を削除し、別シートに画像を貼り付ける
pic.Delete
Set newSh = InsertPictureNewSheet(oFile.Path)
listSh.Hyperlinks.Add Anchor:=listSh.Cells(iRow, COL_PICTURE), _
Address:="", _
SubAddress:="'" & newSh.Name & "'!A1", _
TextToDisplay:="■別シート■"
End Sub
'---------------------------------------------------------------------------------------------------
'【処 理 名】InsertPictureNewSheet
'【処理概要】シートを新規作成しセル上に画像を挿入する
'【引 数】[I]ByVal filePath As String
'【返 却 値】ワークシートオブジェクト
'---------------------------------------------------------------------------------------------------
Private Function InsertPictureNewSheet(ByVal filePath As String) As Worksheet
Dim sh As Worksheet 'シートオブジェクト
Dim folderName As String 'フォルダ名
Dim fileBaseName As String '拡張子なしのファイル名
Dim pic As Picture '画像オブジェクト
Dim buf As Variant
Dim oFso As New FileSystemObject 'ファイルシステムオブジェクト
'ワークシートを追加する
Set sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
'フォルダ名を取得する
buf = Split(filePath, "\")
folderName = buf(UBound(buf) - 1)
'ファイル名を取得する
fileBaseName = oFso.GetBaseName(filePath)
'ファイル名を設定する
Call SetSheetName(sh, folderName & "_" & fileBaseName)
'画像を挿入する
Set pic = sh.Pictures.Insert(filePath)
'画像の位置を調整する
pic.Top = sh.Range("B4").Top + 5
pic.Left = sh.Range("B4").Left + 5
Set InsertPictureNewSheet = sh
End Function
'---------------------------------------------------------------------------------------------------
'【処 理 名】SetSheetName
'【処理概要】ワークシートの名前を変更する
'【引 数】[I]ByVal sh As Worksheet
' [I]ByVal sheetName As String
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub SetSheetName(ByVal sh As Worksheet, ByVal sheetName As String)
Dim convertedSheetName As String
'シート名として不正な文字を"_"に置換する
convertedSheetName = ConvInvalidCharacterAsSheetName(sheetName)
'左側から31文字を設定する
On Error Resume Next
sh.Name = Left(convertedSheetName, 31)
On Error GoTo 0
End Sub
'---------------------------------------------------------------------------------------------------
'【処 理 名】ConvInvalidCharacterAsSheetName
'【処理概要】Excelのシート名に使用できない文字を"_"に置換する
'【引 数】[I] ByVal sheetName As String：シート名
'【返 却 値】変換後シート名
'---------------------------------------------------------------------------------------------------
Public Function ConvInvalidCharacterAsSheetName(ByVal sheetName As String) As String
'ツール ＞ 参照設定 ＞ microsoft vbscript regular expressions
Dim regEx As New RegExp
'コロン(:)、円記号(\)、疑問符(?)、角括弧 ([)、角括弧 (])、スラッシュ(/)、アスタリスク(*)
regEx.Pattern = "[:|\\|\?|\[|\]|\/|\*]+"
ConvInvalidCharacterAsSheetName = regEx.Replace(sheetName, "_")
Set regEx = Nothing
End Function
'---------------------------------------------------------------------------------------------------
'【処 理 名】IsImageFile
'【処理概要】画像ファイルの拡張子であるか確認する
'【引 数】[I] ByVal FilePath As String：ファイルパス
'【返 却 値】True：画像ファイル／False：画像ファイルではない
'---------------------------------------------------------------------------------------------------
Function IsImageFile(filePath As String) As Boolean
Dim oFso As New FileSystemObject 'ファイルシステムオブジェクト
Dim extension As String
Dim pos As Integer
' ファイル名から拡張子を取得
extension = oFso.GetExtensionName(filePath)
' 拡張子を小文字に変換
extension = LCase(extension)
IsImageFile = False
Select Case extension
Case "jpg", "jpeg", "png", "bmp", "gif", "ico", "svg"
IsImageFile = True
End Select
End Function
