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

'画像を挿入する。画像サイズと位置はとりあえず0に設定する

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


特集記事