개요

디렉토리에있는 여러 이미지를 Excel 시트에 하나씩 붙여 넣는 작업이 있습니다.
1장씩 수작업으로 코피페 붙여넣기는 상당히 번거롭기 때문에, 일괄로 붙이는 매크로를 작성했습니다

다음과 같이 디렉토리에 이미지 파일 배치


매크로를 실행하면 Excel에 시트를 만들고 이미지를 붙여 넣습니다.

이미지 붙여넣기 샘플 매크로

위를 수행하는 매크로는 다음과 같습니다.

SampleMain 메서드에서 구현한 것처럼
SetDirImageFile 메서드에 대해 다음 인수 값을 설정하고 실행하면
지정된 시트가 만들어지고 이미지가 붙여 넣어집니다.
첫 번째 인수 : 이미지를 붙여 넣는 시트 이름 (없는 경우 런타임에 생성)
제2 인수: 붙여넣기 대상 이미지가 있는 디렉토리
제3 인수:장착 방향 0: 횡방향 1: 세로 방향

기존 매크로에서 이미지 붙여넣기만 수행하고 싶다면
PastePicture 메소드만 실행하십시오.
제1 인수: 붙여넣기 화상의 파일 패스
두 번째 인수 : 이미지가 정렬되는 간격
세 번째 인수 : 이미지가 정렬되는 방향 0 : 가로 1 : 세로

'貼り付けマクロ実行メソッド
Sub SampleMain()
    '貼り付けシート名「imgSheet」、
    '取り込み対象画像のディレクトリ「"C:\tmp\img"」
    '貼り付け方向「0」(横方向）
    SetDirImageFile "imgSheet", "C:\tmp\img", 0

End Sub

'フォルダ内の画像ファイルをEXCELに張り付ける
'　sheetName:画像を張り付けるシート名
'　imageFileDirPass:貼り付け対象画像のディレクトリパス
'　direction:画像の並べる方向 0:横 1:縦
Function SetDirImageFile(sheetName As String, imageFileDirPass As String, direction As Integer)

    Dim fileName As String

    '------------シートを作成

    'シートがすでに存在する場合は削除
    'Dim ws As Worksheet
    'Dim flag As Boolean
    'flag = False
    'For Each ws In Worksheets
    '    If ws.Name = sheetName Then
    '        flag = True
    '        Exit For
    '    End If
    'Next ws

    'If flag = True Then
    '    Application.DisplayAlerts = False '削除確認をOFFにする
    '    Sheets(sheetName).Delete
    '    Application.DisplayAlerts = True
    'End If

    'シートを追加
    Worksheets.Add
    ActiveSheet.Name = sheetName

    '貼り付け開始位置 縦、横２セル目から貼り付け開始
    ActiveCell.offset(2, 2).Select

    '------------Dir内のファイルを読取り貼付け

    'Dir内のファイルリストを取得
    '取り込み対象の画像ファイル名、拡張子を指定したい場合はここで指定
    buf = Dir(imageFileDirPass & "\*.*") 
    Do While buf <> ""

        If buf <> "" Then

            filePath = imageFileDirPass & "\" & buf

            '画面イメージを貼り付け
            PastePicture CStr(filePath), 2, direction

        End If

        buf = Dir()
    Loop

End Function

'画像を貼り付ける
'　filePath:画像ファイルパス
'　offset:画像の並べる間の間隔
'　direction:画像の並べる方向 0:横 1:縦
Sub PastePicture(filePath As String, offset As Integer, direction As Integer)
    Dim picture As Shape

    Set picture = ActiveSheet.Shapes.AddPicture( _
        fileName:=filePath, _
        LinkToFile:=False, SaveWithDocument:=True, _
        Left:=Selection.Left, Top:=Selection.Top, _
        Width:=0, Height:=0)

    picture.ScaleHeight 1!, msoTrue
    picture.ScaleWidth 1!, msoTrue

    '次の貼り付け位置にセルを移動
    If direction = 0 Then
        MoveRight picture.Width, offset
    Else
        MoveDown picture.Height, offset
    End If

End Sub

'画像の範囲分Cellを下に移動
'　pt:画像のポイント
'　offset:画像の並べる間の間隔(Pixel単位)
Sub MoveDown(pt As Double, offset As Integer)
    Dim moved As Double

    moved = 0
    Do While moved <= pt
        'ActiveCell.heightはポイント単位
        moved = moved + ActiveCell.Height
        ActiveCell.offset(1, 0).Activate
    Loop
    ActiveCell.offset(offset, 0).Activate
End Sub

'画像の範囲分Cellを右に移動
'　pt:画像のポイント
'　offset:画像の並べる間の間隔(Pixel単位)
Sub MoveRight(pt As Double, offset As Integer)
    Dim moved As Double

    moved = 0
    Do While moved <= pt
        'ActiveCell.widthはポイント単位
        moved = moved + ActiveCell.Width
        ActiveCell.offset(0, 1).Activate
    Loop
    ActiveCell.offset(0, offset).Activate
End Sub