投稿/コメントを表示します。

エクセルVBA外部連携講座
ファイルの操作・フォルダの操作説明

たかちゃんさんの投稿

(投稿ID: 4983)

ファイルシステムオブジェクトを使用して、エクセルに写真を張り付け
工事現場の作業報告書のようなものを作成してみました。

事前準備：
エクセルでは”ひな形”という名前のシートを作成し、全てのセルの高さ20に設定。
写真の横にコメントを書ける罫線を引くなどしておく。

ひな形シートをコピーして、指定フォルダの写真を3枚貼り
再び、ひな形シートをコピーして、指定フォルダの残りの写真を
３枚づつ貼っていくマクロです。

Excel2019で動作確認済み。記念に投稿させて頂きました。
'Microsoft Scripting Runtimeにチェック→FSOを使用する為
Sub 画像貼り付け()
    Dim lngTop As Long 'TOPの余白用
    Dim fs As FileSystemObject
    Dim objFile As Scripting.File
    Dim objFldr As Scripting.Folder
    Dim c As Long '写真貼り付けのカウント用
    Dim cFiles As Long 'ファイルの数
    Dim cLast As Long  '最後の3の倍数用
    Dim ws As Worksheet  '作業用ワークシート
    
    Set fs = New Scripting.FileSystemObject
    Set objFldr = fs.GetFolder(ThisWorkbook.Path & "\写真")

    '最初は、写真を貼るシートをコピーする
    Worksheets("ひな形").Copy after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Format(Date, "yymmdd")
    Set ws = ActiveSheet
    
    c = 1 '写真を貼り付けるカウント用
    lngTop = 20 '写真貼の際、Topの余白を20の意味
    
    cFiles = objFldr.Files.Count 'フォルダの中のファイル数
    
    'A4 1枚に3枚づつ写真を貼り付ける。最後の3の倍数では
    'シート（ページ）を追加したくない為、ここで最後の3の倍数を確認
    If cFiles Mod 3 = 0 Then
        cLast = (cFiles \ 3) * 3
    End If
    
    '写真を貼り付け
    For Each objFile In objFldr.Files

        ws.Shapes.AddPicture _
            Filename:=objFile, _
            LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=20, _
            Top:=lngTop, _
            Width:=300, _
            Height:=200
        
        lngTop = lngTop + 200 + 20
        
        '3回写真を貼ったら、次のページ（シート）を作成
        '但し、最後の3の倍数ではページ（シート）を作成しない
        If c Mod 3 = 0 And c <> cLast Then
            Worksheets("ひな形").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Format(Date, "yymmdd") & "_" & c
            Set ws = ActiveSheet
            lngTop = 20
        End If
        
        c = c + 1
    Next
    
    Set objFile = Nothing
    Set objFldr = Nothing
    Set fs = Nothing
    
End Sub








2021/01/12 20:30