エビデンス貼り付け(画像貼り付け，操作マニュアル作成）マクロ その２

１　前回より学習が進んだので，記述を整理した．

　　使い方は，Excelファイルの入っているフォルダと同じフォルダ内に取り込みたいファイルを格納する．貼付開始セルをクリックした状態で，マクロを起動すると，下方向に画像ファイルを貼り付ける．貼り付けの順番は，ファイル名に数字を振ってコントロールする．

２　コード

'**
'*　画像貼付のセル結合対応版
'*　　貼付順をコントロールするためにファイル名に数字をふること
'*
Sub 画像貼付7()
    Application.ScreenUpdating = False
    
    '前提：MicroSoft Scripting Runtime を事前に参照設定しておくこと
    With New FileSystemObject
        Dim myFolder As Folder: Set myFolder = .GetFolder(ThisWorkbook.Path)
        Dim myFiles As Files: Set myFiles = myFolder.Files
    End With
    
    '貼付開始位置
    Dim my貼付セル As Range: Set my貼付セル = ActiveCell
    Dim my貼付ファイル As file
    For Each my貼付ファイル In myFiles
        '画像ファイル以外(設定ファイルなどの隠しファイル)はスキップ
        If Not (isPicture(my貼付ファイル)) Then GoTo Continue
        
        '削除（ぴったり重なって張り付けるのを防止）
        Call deletePictureInTargetCell(my貼付セル)
        
        '貼付
        Call PicturePasteInMergeArea(my貼付ファイル, my貼付セル)
        
        '貼付先セルを１つ下のセル（結合セル）に移動
        Set my貼付セル = my貼付セル.Offset(1, 0)
'画像ファイル以外（隠しファイルなど）ならNext(次ファイル)へ
Continue:
    Next my貼付ファイル
    
    Application.ScreenUpdating = False
    MsgBox "完了"
End Sub

'**
'*　画像ファイルかどうか，拡張子をチェック
'*
Function isPicture(targetFile As file)
    '前提：MicroSoft Scripting Runtime を事前に参照設定しておくこと
    With New FileSystemObject
        Select Case .GetExtensionName(targetFile)
            Case "jpeg", "jpg", "gif", "png"
                isPicture = True
            Case Else
                isPicture = False
        End Select
    End With
End Function

'**
'*　貼る前に画像あったら消す．ぴったり重ねて貼っちゃうと見た目に分からないままExcelファイルが重くなるので．
'*
Function deletePictureInTargetCell(my貼付セル As Range)
    Dim myshape As Shape
    For Each myshape In ActiveSheet.Shapes
        If myshape.TopLeftCell.Address = my貼付セル.Address Then
            myshape.Delete
        End If
    Next
End Function

'**
'*　画像貼付の結合セル対応版
'*
Function PicturePasteInMergeArea(my貼付画像 As file, my貼付セル As Range)
    '仮に縦横サイズ0で（引数Width,Height(ポイント単位)が省略不可なので）
    With ActiveSheet.Shapes.AddPicture( _
                Filename:=my貼付画像.Path, _
                linktofile:=False, _
                savewithdocument:=True, _
                Left:=my貼付セル.MergeArea.Left, _
                Top:=my貼付セル.MergeArea.Top, _
                Width:=0, _
                Height:=0)
        ' ’既に入力済の文字が消えてよければ右横にファイル名を書いておくのもアリかも．
        'my貼付セル.Offset(0, 1).Value = myfile.Name
        '
        '縦横比1倍に戻す
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue
        
        '画像を縮小してセルに収める
        Dim my横倍率 As Double: my横倍率 = my貼付セル.MergeArea.Width / .Width
        Dim my縦倍率 As Double: my縦倍率 = my貼付セル.MergeArea.Height / .Height
        If my縦倍率 > my横倍率 Then
            Dim my縮小率
            my縮小率 = my横倍率
        Else
            my縮小率 = my縦倍率
        End If
        Const my余白ポイント As Long = 6    'どれだけ枠から離すかは好み
        .Width = .Width * my縮小率 - my余白ポイント       '左右
        .Height = .Height * my縮小率 - my余白ポイント    '上下
        '画像を縦横の中央に配置(余白を上下左右均等に割り振る）
        ''例　横長画像を正方形セルに入れるなら、左右余白は３ずつになる(横長画像なら上下は余白大きい)
        .Left = .Left + (my貼付セル.MergeArea.Width - .Width) / 2
        .Top = .Top + (my貼付セル.MergeArea.Height - .Height) / 2
    End With
End Function

３　参考

excel-ubara.com