Option Explicit
'**
'* 画像貼付のセル結合対応版
'* 貼付順をコントロールするためにファイル名に数字をふること
'* 画像があったら，そのセルを飛ばして下のセルに貼る．
Sub 画像貼付12()
' 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 file
Dim my貼付セル As Range: Set my貼付セル = ActiveCell
For Each my貼付ファイル In myFiles
'画像ファイル以外(設定ファイルなどの隠しファイル)はスキップ
If Not (isPicture(my貼付ファイル)) Then GoTo Continue
'貼付セル決定（重複張り付けを防止）
Set my貼付セル = findNoPictureCellDown(my貼付セル)
' my貼付セル.Show
'貼付
Call PastePicture(my貼付ファイル, my貼付セル)
'貼付先セルを１つ下の(結合)セルに移動
Set my貼付セル = my貼付セル.Offset(1, 0)
'画像ファイル以外（隠しファイルなど）ならNext(次ファイル)へ
Continue:
Next my貼付ファイル
Application.ScreenUpdating = True
Application.Goto my貼付セル, True
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
'**
'* 貼付対象セルに画像があったら，画像がないセルまで下にずらす．
'* @param my貼付セル {range}
'* @return {range} my貼付のセルから下方向に，画像がない最初のセルを探して返す
Function findNoPictureCellDown(ByRef my貼付セル As Range) As Range
Do
Dim my仮貼付セル As Range: Set my仮貼付セル = my貼付セル
Dim myshape As Shape
For Each myshape In ActiveSheet.Shapes
If myshape.TopLeftCell.Address = my貼付セル.Address Then
'my貼付セルを下にずらす（その後，もう一度Doループを繰り返すことになる）
Set my貼付セル = my貼付セル.Offset(1, 0)
Exit For
End If
Next
'仮貼付セルと貼付セルが一致しない（=仮貼付セルに画像があった）場合は繰り返す
'→改めてズラす必要があるか画像の存在チェックを繰り返す
Loop While Not (my仮貼付セル.Address = my貼付セル.Address)
'仮貼付セルと貼付セルが一致した（=画像がないセルまで下がりきった）ので，そのセルを返す
Set findNoPictureCellDown = my貼付セル
End Function
'**
'* 結合セルにも対応するため，MergeAreaを使用している
'＊ jpegにして容量減
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, 2).Value = my貼付画像.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余白ポイント '上下
.Cut
End With
'jpegにして容量減らす．ただし，後からサイズ変えると画質荒くなる．
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
With Selection
'エラー対策する？
'If .Type <> msoPicture Then Exit Sub
'画像を縦横の中央に配置(余白を上下左右均等に割り振る）
''例 横長画像を正方形セルに入れるなら、左右余白は３ずつになる(横長画像なら上下は余白大きい)
.Left = my貼付セル.MergeArea.Left + (my貼付セル.MergeArea.Width - .Width) / 2
.Top = my貼付セル.MergeArea.Top + (my貼付セル.MergeArea.Height - .Height) / 2
'背面に持っていく（後で図形挿入して印つけるときのため）
.ShapeRange.ZOrder msoSendToBack
End With
End Sub
'**
'* アクティブセルの列の画像を全部消す
'*
Sub deletePictureInColumn3()
Dim m As String: m = ""
m = m & "現在" & Split(ActiveCell.Address, "$")(1) & "列を選択しています．" & vbNewLine
m = m & Split(ActiveCell.Address, "$")(1) & "列にある画像等を全削除しますか？" & vbNewLine
If MsgBox(m, vbYesNo + vbExclamation, "削除したら元に戻せません") = 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
MsgBox "削除完了"
End Sub
