【VBA】ドラッグアンドドロップできるユーザーフォーム｜ListView

Option Explicit
' 【ListViewの初期設定】
' ツールボックスを表示→ツールボックスの上で右クリック→その他のコントロール→「Microsoft ListView Control x.x」にチェック

Private Const AcceptCount As Long = 1 '取り込むファイル数制限
Public DDItems As Collection 'リストビューのコレクション：値取得用

'【色設定】
'※調べ方：Debug.PrintでRGBを出力する
'数字はパレットで出てくる上からの順
Private Const Gray2 As Long = 14540253 'RGB(221,221,221)
Private Const Gray5 As Long = 4210752 'RGB(64, 64, 64)
Private Const Red1 As Long = 13421823 'RGB(255,204,204)

Private Const Black As Long = 526344 'RGB(8,8,8) ※vbBlackは0,0,0
Private Const ColorBack As Long = Gray2
Private Const ColorHeader As Long = Gray5
Private Const ColorAccent As Long = Red1

Private lv As DDListView '※リストビューはクラスで扱う

Private Sub UserForm_Initialize()
    kFormNonCaption Me, True

    Set lv = New DDListView
    lv.Init Me.ListView1, AcceptCount
    
    'キャンセルボタンが押されたときIsCancelを表示するラベル：見た目では隠す
    With lbl_IsCancel
        .Caption = "NotCancel"
        .Visible = False
    End With
    
    '確認用テキストを非表示にする
    lbl_confirm_text.Visible = False
    
    '開始時の色設定
    SetStartColor
End Sub

Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
    'クラスにデータを渡して値を取得する
    With lv
        .Go Data
        Set DDItems = .DDItems
        If .IsCancel Then Exit Sub
    End With
    
    '色変更
    SetAfterColor
    
    '確認用テキストを表示する
    lbl_confirm_text.Visible = True
    
    'OKボタンの有効化
    With btn_OK
        .BackColor = vbYellow
        .ForeColor = Black
        .Enabled = True
    End With
End Sub

'開始時の色設定
Private Sub SetStartColor()
    btn_OK.ForeColor = ColorHeader
End Sub

'ドロップ後の色設定
Private Sub SetAfterColor()
    'グレーアウトする
    lbl_target.ForeColor = ColorBack
    lbl_heading.ForeColor = ColorBack
    lbl_backHeading.BorderStyle = fmBorderStyleNone
    
    '目立たせる
    ListView1.BackColor = vbYellow
End Sub
Private Sub btn_OK_Click()
    '閉じるのではなく隠す ※変数を渡すため
    Me.Hide
End Sub
Private Sub btn_cancel_Click()
    Me.Hide
    lbl_IsCancel.Caption = "IsCancel"
End Sub

'labelをつかめるようにするための設定
Private Sub lbl_header_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    FormDrag Me, Button
End Sub
Private Sub lbl_ttl_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    FormDrag Me, Button
End Sub
'ユーザーフォームをつかめるようにするための設定
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    FormDrag Me, Button
End Sub

Public WithEvents lv As MSComctlLib.ListView
Public DDItems As Collection
Public mListItems As listitems
Public IsCancel As Boolean

Private mAcceptCount As Long
Private mListItemsCount As Long
Private DDfiles As Object
Private Sub Class_initialize()
    Set DDItems = New Collection
End Sub
Private Sub Class_Terminate()
    Set DDItems = Nothing
End Sub
Public Sub Init( _
                            ByVal vLV As MSComctlLib.ListView, _
                            ByVal vAcceptCount As Long)
    Set lv = vLV
    mAcceptCount = vAcceptCount

    With lv
        .OLEDropMode = ccOLEDropManual '★これが一番重要：ファイルをドロップできるようにする設定
        .View = lvwReport '一覧表示
        .AllowColumnReorder = True '列幅の変更を許可
        .LabelEdit = lvwManual 'ラベル編集負荷
        .MultiSelect = True '複数選択
        .Gridlines = False 'グリッド線
        .FullRowSelect = False '行全体を選択
        .CheckBoxes = False 'チェックボックス

        '列の見出しと幅
        .ColumnHeaders.Add , "key1", "", 20, lvwColumnLeft
        .ColumnHeaders.Add , "key2", "name", 300, lvwColumnLeft
        .ColumnHeaders.Add , "key3", "path", 500, lvwColumnLeft
    End With
End Sub
'リストビューにファイルがドロップされた時にDataを受け取る
Public Sub Go(ByVal Data As Object)
    IsCancel = False
    Set DDfiles = Data.files
    Dim DDCount As Long: DDCount = DDfiles.count
    
    'オブジェクトにする：ローカルウィンドウで確認できるようにするため
    Set mListItems = lv.listitems
    mListItemsCount = mListItems.count
    
    'ドロップするたびに全書き換えしない場合は、「DDCount + mListItemsCount」にする
    If DDCount > mAcceptCount Then
        Call MsgRedoMacro("ドロップできるファイルは" & mAcceptCount & "個のみです")
        IsCancel = True
        Exit Sub
    End If
    
    '既存のリストをクリアする：ドロップするたびに全書き換えする場合
    mListItems.Clear
    
    'Dataの値を取得
    Dim DDItem As DDItem
    Dim i As Long
    For i = 1 To DDCount
        'コレクションに追加 ★DDItemクラスを用意
        Set DDItem = New DDItem
        DDItems.Add DDItem
        With DDItem
            .filePath = DDfiles(i)
            .fileName = GetFileNameFromFullPath(.filePath)
            .folderPath = CutAfterLastStr(.filePath, "\") '\前までのテキストにする
            
            '開いていたら閉じる：開きっぱなしでもエラーにならない場合は不要
            Call CloseOpenedBook(.filePath)
        End With
        Set DDItem = Nothing
    Next
    
    'リストビューに表示する
    DispItems
End Sub
'リストビューにアイテムを表示する
Private Sub DispItems()
    Dim count As Long: count = DDItems.count
    Dim i As Long: i = 1
    Dim v As Variant
    For Each v In DDItems
        With mListItems.Add
            .text = i
            .SubItems(1) = v.fileName
            .SubItems(2) = v.filePath
        End With
        i = i + 1
    Next
End Sub

Public fileName As String
Public filePath As String
Public folderPath As String

    With UserForm 'ユーザーフォーム名
        .lbl_target.Caption = "ファイルA" 'アップするファイル名
        .Show
        
        'Me.Hideで戻り後、キャンセル判定
        If .lbl_IsCancel.Caption = "IsCancel" Then
            Exit Sub
        End If
        
        'タイムはここから計測
        StartTimer = Timer  '(パブリック変数使用：Public StartTimer As Double)
        
        'フォーム内の値を取得
        Dim fileName As String
        Dim folderPath As String
        Dim filePath As String

        fileName = .DDItems(1).fileName
        folderPath = .DDItems(1).folderPath
        filePath = .DDItems(1).filePath
        
        Unload UserForm
    End With