ExcelVBAでフォルダ内の画像カタログを作ってみました。セルの高さで画像表示を変更できます。

はじめに
使い方
プログラム解説
最後に
1. 関連記事:

はじめに

　フォルダ内にある画像の一覧をイメージ付きで表示するサンプルです。
画像の大きさは１つのセルの高さに応じて拡縮されます。

　画像はリンクで貼り付けますので、Excelファイルのサイズはあまり大きくなりません。
プログラムソースを参考にして頂き、ご自身のプログラムに活かしてみてください。

ImageCatalog.zip ダウンロード

使い方

１．画像表示させたいフォルダを「フォルダ選択」ボタンで選択します。
　　B2セルにパスが表示されます。

２．A5セルの高さを基準にして表示しますので、適当な高さに広げます。
　　A５より下の行は、A5の高さに調整されます。

３．「画像セット」ボタンを押すと、A列に画像が表示され、B列にファイル名が表示されます。

４．A5セルの高さを変更して「画像セット」ボタンを押すと、画像サイズが変更されて再表示されます。

５．「リストを削除」ボタンで、５行目以降の A列と B列の値が削除されます。

プログラム解説

　本プログラムは、全て標準モジュールに記述します。

画像フォルダ名をセット

「フォルダ選択」ボタンで呼び出されるプログラムです。フォルダ選択ダイアログを出して、結果をB2セルに代入しています。

'画像フォルダ名をセット
Sub setImageFolder()

    'フォルダ選択ダイログ
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダの選択"

        .InitialFileName = ThisWorkbook.Path    '初期パスを設定

        If Not .Show Then Exit Sub  'ダイアログを表示 キャンセルならば終了

        ActiveSheet.Range("B2") = .SelectedItems(1)

    End With
 
End Sub

画像ファイルか判断する

　引数で与えられたファイル名が画像ファイルであればTrueを返し、そうでなければFalseを返します。
この関数で、リストに加えるかどうか判断します。

'画像ファイルか判断する
Function IsImageFile(ByVal filename As String) As Boolean

    Dim b As Boolean
    Dim pos As Long

    b = True

    pos = InStrRev(filename, ".")

    If pos > 0 Then
        Select Case LCase(Mid(filename, pos + 1))   'LCase;アルファベットの大文字を小文字に変換
            Case "jpeg"
            Case "jpg"
            Case "gif"
            Case "png"
            Case "bmp"
            Case "tif"
            Case "tiff"
            
            Case Else
                b = False
        End Select
    Else
        b = False
    End If

    IsImageFile = b

End Function

全ての画像とファイル名を削除

　「リストを削除」ボタンで呼び出される関数です。
最初に全てのシェイプを巡り、リンク画像であれば削除していきます。
　次に、ファイル名部分をクリアし、最後に６行目以降のセルの高さを標準サイズに変更しています。

'全ての画像とファイル名を削除
Sub DeleteAllPictureItems()

    Dim ws As Worksheet
    Dim mShape As Shape
    Dim r As Long

    Application.ScreenUpdating = False

    Set ws = ActiveSheet

    'それまでの画像をクリア
    For Each mShape In ws.Shapes
        If mShape.Type = msoLinkedPicture Then   '「リンク画像」を削除する
        'If mShape.Type = msoPicture Then   '「画像」を削除する
            mShape.Delete
        End If
    Next

    'ファイル名クリア
    r = ws.Cells(Rows.Count, "B").End(xlUp).row
    If r > 5 Then
        ws.Range(ws.Cells(5, "B"), Cells(r, "B")).ClearContents
    End If
    '高さを標準に戻す
    ws.Range("A6:A" & r).RowHeight = ActiveSheet.StandardHeight

    Application.ScreenUpdating = True

End Sub

画像とファイル名を貼り付ける

　「画像セット」ボタンで呼び出される関数です。
まず、それまでの値が残っていればクリアしておきます。
次に、B2セルのフォルダ名を取得して、フォルダ内のファイルを循環する処理を行います。
Do Until の部分でフォルダ内のファイルを巡回し、画像ファイルであるかを確認してから、リンク画像として貼り付けていきます。この時、ファイル名はB列に書き込みます。

　貼り付ける際は、A5セルの高さを標準にして貼り付けていきます。

'画像とファイル名を貼り付ける
Sub setPictureList()

    Dim ws As Worksheet
    Dim base_path As String
    Dim file_name As String
    Dim file_path As String
    Dim i As Integer
    Dim mShape As Shape
    Dim r As Long
    Dim h As Integer
    
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    'それまでの画像をクリア
    For Each mShape In ws.Shapes
        If mShape.Type = msoLinkedPicture Then   '「リンク画像」を削除する
        'If mShape.Type = msoPicture Then   '「画像」を削除する
            mShape.Delete
        End If
    Next
    'ファイル名クリア
    r = ws.Cells(Rows.Count, "B").End(xlUp).row
    If r > 5 Then
        ws.Range(ws.Cells(5, "B"), Cells(r, "B")).ClearContents
    End If

    base_path = ws.Range("B2") & "\"
    file_name = Dir(base_path, vbNormal)
    
    file_path = base_path & file_name   
    h = ws.Range("A5").RowHeight
    i = 1
    Do Until file_name = ""
        If IsImageFile(file_name) Then
            'シェイプタイプをリンク画像（msoLinkedPicture）として貼り付ける方法
            ws.Rows(i + 4).RowHeight = h
            ws.Cells(i + 4, 1).Select
            ws.Pictures.Insert(file_path).Select
            Selection.ShapeRange.height = h
            'ファイル名表示
            ws.Cells(i + 4, 2) = file_name
        End If
        file_name = Dir()
        file_path = base_path & file_name
        i = i + 1
    Loop
    ws.Range("B5").Select
    Application.ScreenUpdating = True
End Sub