エビデンス貼付マクロその３

１　その３の経緯

　その２では画像があったら勝手に消した．さすがに乱暴なので，消すか消さないか選択できるようにしようかと考えたが，画像があったらジャンプして下に行けばよいことに気付いた．

２　コード

(1)同一フォルダ内の画像を貼付

'**
'*　画像貼付のセル結合対応版
'*　　貼付順をコントロールするためにファイル名に数字をふること
'*    画像があったら，そのセルを飛ばして下のセルに貼る．
Sub 画像貼付8()
    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 slideToNoPictureCell(my貼付セル)
        
        '貼付
        Call PastePicture(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", "bmp"
                isPicture = True
            Case Else
                isPicture = False
        End Select
    End With
End Function


'**
'*   セルに画像があったら，その下にずれていく．
Sub slideToNoPictureCell(ByRef my貼付セル As Range)
    Dim myshape As Shape
    For Each myshape In ActiveSheet.Shapes
        If myshape.TopLeftCell.Address = my貼付セル.Address Then
            my貼付セル = my貼付セル.Offset(1, 0)
        End If
    Next
    '再帰呼び出し
    Call slideToNoPictureCell(my貼付セル)
End Sub

'**
'*   結合セルにも対応するため，MergeAreaを使用している
Sub PastePicture(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 Sub

(2)削除

 貼付をやり直したいときなどに，アクティブセルのある列の画像を全部消す

'**
'**
'*　特定列の画像を全部消す
'*
Sub deletePictureInColumn()
    If MsgBox("現在選択しているセルの列にある画像等を全部消しますか．", vbYesNo, "削除したら元に戻せません") = vbNo Then
        Exit Sub
    End If
    
    Dim myshape As Shape
    For Each myshape In ActiveSheet.Shapes
        If myshape.TopLeftCell.Column = ActiveCell.Column Then
            myshape.Delete
        End If
    Next
    
    Dim m As String: m = ""
    m = m & "現在選択しているセルの列にある画像等を削除しました．" & vbNewLine
    m = m & "誤って削除した場合は，ファイルを保存しないで閉じてください"
    MsgBox m
End Sub

３