Excel VBA ドラッグアンドドロップで画像をListViewの一覧に登録、切り抜き・サイズ調整後にセルへ嵌めこむマクロ

この手のツールはしょっちゅう作るので、コードを効率よく再利用できるようクラスを作りました。通常はコントロールのイベントプロシージャーに書く複雑なコードをWithEvents 付きのクラスに詰め込みました。

応用例として画像ファイルの閲覧とセルへの貼り付けを行うマクロを紹介します。

機能

- ListView1上に画像をドロップするとOLE DragDropイベントが発生して、パスとファイル名をセットする

- リスト上で選択した行の画像ファイルをImage1コントロール上に表示する

- リスト上で選択した行を上下に移動してリストを並べ替える (selectionMoveUp, selectionMoveDown)

実用性を上げるために、標準モジュールには次の機能を追加しています。

- 選択したセルに合わせて画像を切り抜き・嵌めこむ (trimImage_main, trimImage_sub)

- ユーザーフォームを右クリックから呼び出すために、コンテクストメニューを追加（setContextMenu）

使い方

1. 右クリックから「Photo」を選ぶ

2. リストビューに画像ファイルをドロップ（複数ファイル可能）

3. リストビューをクリックし、画像を表示

4. ダブルクリックで選択セル(単一)に貼り付け

コマンドボタンを追加して、Clickイベントに下記のコード

を追加すれば、複数選択セルに貼り付けることができます。

If Me.ListView1.listItems.Count < 1 Then Exit Sub Dim lvSelectedItems() lvSelectedItems = getSelectedItemFromLv(Me.ListView1, 0) Call trimImage_main(lvSelectedItems)

準備

1. ユーザーフォームにコントロールを配置する

フォーム名は　frmLvPhoto にしておいてください。コンテクストメニューにコマンドを追加するコード（setContextMenu）で使います。

2.サンプル画像を用意する（JPEGまたはBMP)

3. クラスモジュールを追加し、クラス名をclsLvに変更する

4. ユーザーフォームモジュール、標準モジュール、クラスモジュールに下のコードを貼り付ける

5. 標準モジュールのsetContextMenuを実行する

WorkbookのOpenイベントに　Call setContextMenu と書いてブックを保存して開き直す、

または、このマクロ全体をアドインにする等すればこの手間が省け、より実用的になります。

サンプルコード

'******************************************************** 'ユーザーフォームモジュールに書く

'******************************************************** Private lv As clsLv

'初期化時にクラス（clsLv)のインスタンスを作成し、

'ListView1とImage1をセットする Private Sub UserForm_Initialize() Set lv = New clsLv lv.setListView Me.ListView1 lv.setImage Me.Image1 End Sub

'リストビューの選択行を上下に移動する Private Sub CommandButton1_Click() lv.selectionMoveUp End Sub Private Sub CommandButton2_Click() lv.selectionMoveDown End Sub

'********************************************************

'標準モジュールに書く

'********************************************************

'コンテクストメニューにユーザーフォーム表示マクロを登録

Sub setContextMenu() Dim cbCtrl As CommandBarControl Dim cbCtrlChild As CommandBarControl Application.CommandBars("Cell").Reset

Set cbCtrl = Application.CommandBars("Cell").Controls.Add cbCtrl.Caption = "Photo" cbCtrl.OnAction = "showLvPhto" End Sub Sub showLvPhto() frmLvPhoto.Show vbModeless End Sub

'リストビューで選択されている行から指定列の文字列を取得して配列に入れて返す

Function getSelectedItemFromLv(lv As MSComctlLib.ListView, columnNumber As Long) Dim arraySelectedItem() Dim loopIndex As Long Dim arrayIndex As Long For loopIndex = 1 To lv.listItems.Count If lv.listItems(loopIndex).Selected Then ReDim Preserve arraySelectedItem(arrayIndex) If columnNumber = 0 Then arraySelectedItem(arrayIndex) = lv.listItems(loopIndex).Text Else arraySelectedItem(arrayIndex) = lv.listItems(loopIndex).SubItems(columnNumber) End If arrayIndex = arrayIndex + 1 End If Next getSelectedItemFromLv = arraySelectedItem End Function

'読み込んだ画像を、ワークシート上の任意の選択範囲に合わせてトリム・フィットする 'メイン

Sub trimImage_main(filePathArray())

If IsArray(filePathArray) = False Then Exit Sub 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) Set targetRange = targetRanges(rangeCounter) '画像をトリムしてセルにフィットさせるサブルーチンへ。対象Rangeと画像のパス、マージンを引数にする。 Call trimImage_sub(targetRange, imagePath, horizontalMargin, verticalMargin) Next End Sub

'読み込んだ画像を、ワークシート上の任意の選択範囲に合わせてトリム・フィットする 'サブルーチン Sub trimImage_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

'画像のサイズを取得 Dim oriImgWidth As Single: oriImgWidth = targetImage.Width Dim oriImgHeight As Single: oriImgHeight = targetImage.Height Dim imgWidth As Double: imgWidth = oriImgWidth Dim imgHeight As Double: imgHeight = orimgheight '画像の縦横比率を固定 targetImage.LockAspectRatio = msoTrue

'画像の高さを選択Rangeの高さに合わせる targetImage.Height = rangeHeight imgWidth = targetImage.Width

'画像の幅が選択Rangeの幅より小さい場合は、 If imgWidth < rangeWidth Then '画像の幅を選択Rangeの幅よりに合わせる targetImage.Width = rangeWidth End If imgHeight = targetImage.Height imgWidth = targetImage.Width

'選択されているRangeのサイズと画像のサイズの差異を取得 Dim widthDiff As Double: widthDiff = imgWidth - rangeWidth Dim heightDiff As Double: heightDiff = imgHeight - rangeHeight 'Rangeと画像の間に入れる余白を加える

widthDiff = widthDiff + marginWidth heightDiff = heightDiff + marginHeight

With targetImage .LockAspectRatio = msoFalse

'元の画像のサイズと切り抜き前の画像のサイズの比率を求める Dim ori_newSizeRatio As Single ori_newSizeRatio = oriImgHeight / imgHeight '切り抜き幅を求める Dim cropHeight As Single: cropHeight = ori_newSizeRatio * heightDiff Dim cropWidth As Single: cropWidth = ori_newSizeRatio * widthDiff

'切り抜きを実行する .PictureFormat.CropTop = cropHeight / 2 .PictureFormat.CropBottom = cropHeight / 2 .PictureFormat.CropLeft = cropWidth / 2 .PictureFormat.CropRight = cropWidth / 2

'選択範囲に画像を配置する .Left = targetRange.Left + (rangeWidth - .Width) / 2 .Top = targetRange.Top + (rangeHeight - .Height) / 2 .Placement = xlFreeFloating .Placement = xlMove End With

End Sub

'******************************************************** 'クラスモジュール(clsLv)に書く

'******************************************************** Private WithEvents lv As MSComctlLib.ListView Private listItems As listItems Private listItem As listItem Private listItemsCount As Long Private subItemsCount As Long

Private img As msforms.Image Private dataFiles() Private filePath As String Private Const aspectRatio As Single = 3 / 4 'Imageコントロールのアスペクト比 Private Const marginWidth As Double = 0 '画像とセルの間に設ける左右の余白 Private Const marginHeight As Double = 0 '画像とセルの間に設ける上下の余白

'ListViewコントロールをセットする Public Sub setListView(argLv As MSComctlLib.ListView) Set lv = argLv With lv .listItems.Clear .ColumnHeaders.Clear .View = lvwReport .Gridlines = True .AllowColumnReorder = True .HideSelection = False .LabelEdit = lvwManual .MultiSelect = True .FullRowSelect = True .OLEDropMode = ccOLEDropManual .ColumnHeaders.Add , , "filePath", 0, lvwColumnLeft .ColumnHeaders.Add , , "fileName", 180, lvwColumnLeft End With End Sub

'Imageコントロールをセットする Public Sub setImage(argImg As msforms.Image) Set img = argImg img.PictureSizeMode = fmPictureSizeModeZoom img.Height = img.Width * aspectRatio End Sub

'リストビューにファイルがドロップされた時に実行 Private Sub lv_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) Dim loopIndex As Long If Data.Files.Count < 1 Then Exit Sub lv.listItems.Clear For loopIndex = 0 To Data.Files.Count - 1 ReDim Preserve dataFiles(loopIndex) dataFiles(loopIndex) = Data.Files(loopIndex + 1) Next Call addItemToLv Set listItems = lv.listItems listItemsCount = listItems.Count subItemsCount = listItems(1).ListSubItems.Count End Sub

'リストビューにアイテムをセットする Private Sub addItemToLv() Dim loopIndex As Long For loopIndex = 0 To UBound(dataFiles) With lv.listItems.Add .Text = dataFiles(loopIndex) .SubItems(1) = Dir(dataFiles(loopIndex)) End With Next End Sub

'リストビューのアイテムが選択された時に実行 Private Sub lv_ItemClick(ByVal Item As MSComctlLib.listItem) If lv.listItems.Count < 1 Then Exit Sub On Error Resume Next filePath = lv.SelectedItem.Text Call loadImage End Sub

'リストビューのアイテムがダブルクリックされた時に実行 Private Sub lv_DblClick() If lv.listItems.Count < 1 Then Exit Sub

' Call openWith ' Call findFileInExloprer ' Call loadImage

Dim lvSelectedItems() lvSelectedItems = getSelectedItemFromLv(lv, 0) Call trimImage_main(lvSelectedItems) End Sub

'エクスプローラーでファイルの保存場所を開き、ファイルを選択する Private Sub findFileInExloprer() Shell "EXPLORER.EXE /select,""" & filePath & """", vbNormalFocus End Sub

'拡張子に紐づいている標準アプリでファイルを開く Private Sub openWith() CreateObject("Wscript.Shell").Run """" & filePath & """", 5 End Sub

'imgに画像をセットする Private Sub loadImage() img.Picture = LoadPicture(filePath) End Sub

'リストビューで選択されているアイテムを上の行へ移動する Public Sub selectionMoveUp() If listItemsCount < 1 Then Exit Sub If lv.SelectedItem.Index = 0 Then Exit Sub

Dim arraySubItems() As Variant: ReDim arraySubItems(listItemsCount) Dim txt As String Dim rowIndex As Long, rowIndex2 As Long, subItemsIndex As Long

For rowIndex = 1 To listItemsCount Set listItem = listItems(rowIndex) With listItem If .Selected = True Then txt = .Text For subItemsIndex = 1 To subItemsCount arraySubItems(subItemsIndex) = .SubItems(subItemsIndex) Next rowIndex2 = .Index - 1 If rowIndex2 < 1 Then Exit Sub listItems.Remove (.Index)

With listItems.Add(rowIndex2) .Text = txt For subItemsIndex = 1 To subItemsCount .SubItems(subItemsIndex) = arraySubItems(subItemsIndex) Next .Selected = True End With End If End With Next

End Sub

'リストビューで選択されているアイテムを下の行へ移動する Public Sub selectionMoveDown() If listItemsCount < 1 Then Exit Sub If lv.SelectedItem.Index = 0 Then Exit Sub

Dim arraySubItems() As Variant: ReDim arraySubItems(listItemsCount) Dim txt As String Dim rowIndex As Long, rowIndex2 As Long, subItemsIndex As Long

For rowIndex = listItemsCount To 1 Step -1 Set listItem = listItems(rowIndex) With listItem If .Selected = True Then txt = .Text For subItemsIndex = 1 To subItemsCount arraySubItems(subItemsIndex) = .SubItems(subItemsIndex) Next rowIndex2 = .Index + 1 If rowIndex2 > listItemsCount Then Exit Sub listItems.Remove (.Index) With listItems.Add(rowIndex2) .Text = txt For subItemsIndex = 1 To subItemsCount .SubItems(subItemsIndex) = arraySubItems(subItemsIndex) Next .Selected = True End With End If End With Next End Sub