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

最終更新: 3月23日


この手のツールはしょっちゅう作るので、コードを効率よく再利用できるようクラスを作りました。通常はコントロールのイベントプロシージャーに書く複雑なコードを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
    '画像を挿入する。画像サイズと位置はとりあえず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
    '画像のサイズを取得

    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

#クラスモジュール #ドラッグドロップ #ExcelVBA #Listview #WithEvents