ExcelVBA | サムネイル付き写真リストを作成する

2023.01.29
開発系

自分用のVBAメモです。サムネイル付きの写真リストの作り方です。

1. 作りたいもの
2. コード
- 2.1. 備忘録
  - 2.1.1. ①AddPicture関数
  - 2.1.2. ②xlMoveAndSize

作りたいもの

フォルダ「C\test」内の写真をリスト化します。

完成品は以下の通りです。

コード

コードは以下の通りです。

Sub Main()
    
    Dim Folder_Path As String
    Dim Extention As String
    Dim File_Name As String
    Dim Cnt As Long
    
    '初期値
    Folder_Path = Range("C3")
    Extention = Range("C4")
    Cnt = 7
    
    'ワイルドカード付きのファイルパスを生成
    File_Name = Dir(Folder_Path & "*." & Extention)
    
    '各種クリア
    Range(Rows(Cnt), Rows(5000)).ClearContents
    Range(Rows(Cnt), Rows(5000)).ClearFormats
    
    'シート上の全オブジェクトのクリア
    Dim tmp_shape As Object
    For Each tmp_shape In Sheets("Main").Shapes
        tmp_shape.Delete
    Next
    
    '各種設定
    Range(Rows(Cnt), Rows(5000)).RowHeight = 100 '行の高さ
    Range(Cells(Cnt, 2), Cells(5000, 4)).Borders.LineStyle = xlContinuous '罫線
    
    
    
    Do While File_Name <> ""
            
        Call MakeThumbnail(Folder_Path & File_Name, Range("B" & Cnt)) 'サムネイルの挿入
        Range("C" & Cnt) = Folder_Path & File_Name 'ファイルのフルパス
               
        'ハイパーリンク
        ActiveSheet.Hyperlinks.Add _
            Anchor:=Range("D" & Cnt), _
            Address:=Range("C" & Cnt), _
            TextToDisplay:=File_Name

        File_Name = Dir()
        Cnt = Cnt + 1
    Loop
        
End Sub

Function MakeThumbnail(File_Path As String, Cell_range As Object)

    Dim myShape As Object
    
    '------------------------------------------------------------
    '写真の挿入
    '参考： https://learn.microsoft.com/ja-jp/office/vba/api/excel.shapes.addpicture
    '------------------------------------------------------------
    Set myDocument = ActiveSheet
    
    Set myShape = myDocument.Shapes.AddPicture( _
        Filename:=File_Path, _
        LinkToFile:=False, _
        SaveWithDocument:=True, _
        Left:=Cell_range.Left + 25, _
        Top:=Cell_range.Top + 25, _
        Width:=50, _
        Height:=50)
    
    '挿入した画像がセルサイズに合わせてサイズ変更出来るように設定
    myShape.Placement = xlMoveAndSize

End Function