Excel VBA ドラッグ＆ドロップでシートに画像を貼り付ける
選択中のセルの大きさに合わせて画像を貼り付けるマクロです。
＜完成イメージ＞
セルを選択した後、貼り付ける画像を選択してListViewにドロップすると...
選択中のセルの大きさに合わせて貼り付け。縦横の比が合わない場合はトリム
＜準備＞
UserForm1にListView1を配置します。
ListView1のプロパティーを次のように変えます
OLEDropMode: 0 - ccOLEDroptManual
＜ソースコード＞
'Worksheetモジュールまたは標準モジュールに書くコード
Sub Macro1()
UserForm1.Show vbModeless
End Sub
'UserForm1に書くコード
Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim myarray()
Dim arrayIndex As Long: arrayIndex = 1
Dim loopIndex As Long
For loopIndex = 1 To Data.Files.Count
ReDim Preserve myarray(arrayIndex)
myarray(arrayIndex) = Data.Files(loopIndex)
arrayIndex = arrayIndex + 1
Next
Call 画像をセルにはめこむ(myarray)
End Sub
Private Sub 画像をセルにはめこむ(filePathArray() As Variant)
Dim targetSheet As Worksheet: Set targetSheet = ActiveSheet
Dim currentArea As Range
Dim targetRanges() As Range
Dim rangeCounter As Long
Dim itemCounter As Long
For Each currentArea In Selection.Areas
'選択範囲が結合セルの場合
If currentArea.MergeCells Then
ReDim Preserve targetRanges(rangeCounter)
'選択範囲をひとまとめにして、Range型配列に入れる
Set targetRanges(rangeCounter) = _
targetSheet.Range(currentArea.Address(False, False))
rangeCounter = rangeCounter + 1
Else
'非結合セルが連続して（隣接して）選択されている場合も、範囲としてひとまとめに扱われてしまうため、
'ここでは、選択範囲内のセルを .Item で取得し、ばらばらにしてRange型配列に入れる。
For itemCounter = 1 To currentArea.Cells.Count
ReDim Preserve targetRanges(rangeCounter)
Set targetRanges(rangeCounter) = _
targetSheet.Range _
(currentArea.Item(itemCounter).Address(False, False))
rangeCounter = rangeCounter + 1
Next
End If
Next
Dim imagePath As String
Dim targetRange As Range
For rangeCounter = 0 To UBound(targetRanges)
'写真が足りなくなったら抜ける
If rangeCounter >= UBound(filePathArray) Then Exit Sub
imagePath = filePathArray(rangeCounter + 1)
Set targetRange = targetRanges(rangeCounter)
'画像をトリムしてセルにフィットさせるサブルーチンへ。対象Rangeと画像のパス、マージンを引数にする。
Call 画像をトリムしてセルにフィット(targetRange, imagePath, 0, 0)
Next
End Sub
Private Sub 画像をトリムしてセルにフィット(targetRange As Range, imagePath As String, _
Optional marginWidth As Double, Optional marginHeight As Double)
Dim targetWS As Worksheet: Set targetWS = targetRange.Parent
'選択されているRangeのサイズを取得
Dim rangeWidth As Double: rangeWidth = targetRange.Width
Dim rangeHeight As Double: rangeHeight = targetRange.Height
'画像を挿入する。画像サイズと位置はとりあえず０に設定する
Dim targetImage As Shape: Set targetImage = _
targetWS.Shapes.AddPicture(imagePath, msoFalse, msoTrue, 0, 0, 0, 0)
'縦横の比率を保持したまま、画像を元の大きさに戻す
targetImage.ScaleHeight 1, msoTrue
targetImage.ScaleWidth 1, msoTrue
'-------------------------------------------------
'＜ここから＞画像サイズを選択Range以上に設定する
'-------------------------------------------------
'画像のサイズを取得
Dim imgWidth As Double: imgWidth = targetImage.Width
Dim imgHeight As Double: imgHeight = targetImage.Height
'画像の縦横比率を固定
targetImage.LockAspectRatio = msoTrue
'画像の高さを選択Rangeの高さに合わせる
targetImage.Height = rangeHeight
imgWidth = targetImage.Width
'画像の幅が選択Rangeの幅より小さい場合は、
'画像の幅を選択Rangeの幅よりに合わせる
If imgWidth < rangeWidth Then
targetImage.Width = rangeWidth
End If
imgHeight = targetImage.Height
imgWidth = targetImage.Width
'-------------------------------------------------
'＜ここまで＞画像サイズを選択Range以上に設定する
'-------------------------------------------------
'選択されているRangeのサイズと画像のサイズの差異を取得
Dim widthDiff As Double: widthDiff = imgWidth - rangeWidth
Dim heightDiff As Double: heightDiff = imgHeight - rangeHeight
'Rangeと画像のマージンを設定
widthDiff = widthDiff + marginWidth
heightDiff = heightDiff + marginHeight
'調整後の画像のサイズ
Dim imgWidthNew As Double: imgWidthNew = imgWidth - widthDiff
Dim imgHeightNew As Double: imgHeightNew = imgHeight - heightDiff
'画像のトリム
With targetImage
.LockAspectRatio = msoFalse
'トリムしたい高さ
.IncrementTop heightDiff
'トリム後の高さ / 元の画像の高さ
.ScaleHeight imgHeightNew / imgHeight, msoFalse, msoScaleFromTopLeft
'元の画像の高さ
.PictureFormat.Crop.PictureHeight = imgHeight
'トリムしたい幅
.IncrementLeft widthDiff
'トリム後の幅 / 元の画像の幅
.ScaleWidth imgWidthNew / imgWidth, msoFalse, msoScaleFromTopLeft
'元の画像の幅
.PictureFormat.Crop.PictureWidth = imgWidth
End With
'選択範囲に画像を配置する
With targetImage
.Left = targetRange.Left + (rangeWidth - .Width) / 2
.Top = targetRange.Top + (rangeHeight - .Height) / 2
.Placement = xlFreeFloating
.Placement = xlMove
End With
End Sub
