VBA応用(ドラッグ＆ドロップでファイル名を受ける)

セルが直接ドラッグ＆ドロップでファイル名を受けてくれれば良いのですが．．．．

VB6時代のListViewコントロール．．．？「ファイルを開く」のダイアログを表示させてファイル名を受け取るのが一般的ですが、たいていは横でエクスプローラが開いていてドラッグさせれば済むことが多いと思います。ですが、この「ドラッグ＆ドロップでファイル名を受ける」は簡単ではありません。

ネットで調べるとほとんどはVB6時代のListViewコントロールを使ったものですが、 VB6(VisualBasic6.0)自体が20年以上前のもので、それを利用して仕組みを作成しても実行環境が同等の環境か不明です。当然ですが64ビット版の対応もありません。

このページでは、VB6時代のListViewコントロールは使わず、ユーザーフォーム自体でドラッグ＆ドロップでファイル名を受ける方法としてのサンプルを提示します。

既存の仕組みに取り入れる場合は若干の修正が必要ですが、大きな変更は必要ないと思います。

サンプルの動作を見てみましょう。

ファイル名を登録するセルをダブルクリックすると、このように「対象ファイルのドラッグ登録」というフォームが表示されます。
このフォーム上にフォルダウィンドウやエクスプローラからファイルをドラッグ＆ドロップさせれば、起動したセルにフルパスファイル名が登録されるという仕組みです。

「ファイル⑥」だけは複数セルに対して１回のドラッグで行なう対応になっています。

それではソースコードです。

まずは、呼び出し側の「Sheet1」です。


'***************************************************************************************************
'   ドラッグ＆ドロップでファイル名を受けるサンプル              Sheet1(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 20/04/18(1.0.0)新規作成
' 20/04/19(1.0.0)複数受け取り時の要素上限チェックを追加
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "対象ファイルのドラッグ登録"
' 複数ファイル範囲
Private Const g_cnsMultiRange As String = "$B$12:$B$21"
' ファイル名受け取り対象セル
Private Const g_cnsAllowRange As String = "$B$2,$B$4,$B$6,$B$8,$B$10," & g_cnsMultiRange

'***************************************************************************************************
'   ■■■ ワークシートイベント ■■■
'***************************************************************************************************
'* 処理名　：Worksheet_BeforeDoubleClick
'* 機能　　：セルダブルクリックイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(既定)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2020年04月18日
'* 作成者　：井上　治
'* 更新日　：2020年04月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, ByRef Cancel As Boolean)
    '-----------------------------------------------------------------------------------------------
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngIx As Long                                               ' テーブルINDEX
    ' ファイル名受け取り対象セル以外は終了
    If Intersect(Target, Range(g_cnsAllowRange)) Is Nothing Then Exit Sub
    lngRow = Target.Row
    '-----------------------------------------------------------------------------------------------
    ' ユーザーフォーム起動
    g_lngTblEntFileMax = -1
    UF_EntFiles.Show
    Unload UF_EntFiles
    ' キャンセルは終了
    If g_lngTblEntFileMax < 0 Then Exit Sub
    '-----------------------------------------------------------------------------------------------
    ' 単一ファイルセルか
    If lngRow < 12 Then
        ' 単一ファイルセル
        If g_lngTblEntFileMax > 0 Then
            MsgBox "単一ファイルをドラッグして下さい。", vbExclamation, g_cnsTitle
        Else
            Cells(lngRow, 2).Value = g_tblEntFile(0)
        End If
    Else
        ' 複数ファイルセル
        If g_lngTblEntFileMax > 9 Then
            MsgBox "最大10ファイルをドラッグして下さい。", vbExclamation, g_cnsTitle
        Else
            lngRow = 12
            Range(g_cnsMultiRange).ClearContents
            ' テーブルから転記
            Do While lngIx <= g_lngTblEntFileMax
                Cells(lngRow, 2).Value = g_tblEntFile(lngIx)
                ' 次へ
                lngIx = lngIx + 1
                lngRow = lngRow + 1
            Loop
        End If
    End If
    Cancel = True
End Sub

'------------------------------------------<< End of Source >>--------------------------------------

今回のサンプルでは「ファイル①」から「ファイル⑤」までは単一ファイル、「ファイル⑥」だけは複数ファイルの受け取りです。受け取ったフルパスファイル名は下で説明する「g_tblEntFile」に配列で格納されます。また、このテーブルの要素上限値が「g_lngTblEntFileMax」に格納されます。

「g_lngTblEntFileMax」の値がマイナス値であれば「未登録(キャンセル)」、ゼロであれば「単一ファイル」、１以上であれば「複数ファイル」と判断できます。
複数ファイルを受け取るセルかどうかは「ファイル⑥」の行番号が１２なのでそれ未満かどうかで判断しています。

次はユーザーフォーム「UF_EntFiles」です。


'***************************************************************************************************
'   ファイル名受け取りフォーム(共通)                            UF_EntFiles(UserForm)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 17/09/24(2.0.0)新規作成
' 19/10/28(2.1.0)Declare記述の変更(64ビット版Excel対応)
' 20/04/18(2.2.0)サンプル用に汎用化
'***************************************************************************************************
Option Explicit
'===================================================================================================
' ウィンドウハンドルを返す
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "USER32.dll" Alias "FindWindowA" _
    (ByVal lpClassName As Any, ByVal lpWindowName As Any) As LongPtr
#Else
Private Declare Function FindWindow Lib "USER32.dll" Alias "FindWindowA" _
    (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
#End If

'***************************************************************************************************
'   ■■■ ユーザーフォームイベント ■■■
'***************************************************************************************************
'* 処理名　：UserForm_Activate
'* 機能　　：フォーム表示イベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_Activate()
    '-----------------------------------------------------------------------------------------------
    modDragFiles.g_lngHwnd = FindWindow("ThunderDFrame", Me.Caption)
    ' サブクラス開始
    Call modDragFiles.GP_StartSubClass(Me)
End Sub

'***************************************************************************************************
'* 処理名　：UserForm_BeforeDragOver
'* 機能　　：フォームドラッグイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(既定)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
                                    ByVal Control As MSForms.Control, _
                                    ByVal Data As MSForms.DataObject, _
                                    ByVal X As Single, _
                                    ByVal Y As Single, _
                                    ByVal State As MSForms.fmDragState, _
                                    ByVal Effect As MSForms.ReturnEffect, _
                                    ByVal Shift As Integer)
    '-----------------------------------------------------------------------------------------------
    AppActivate Me.Caption
End Sub

'***************************************************************************************************
'* 処理名　：UserForm_Initialize
'* 機能　　：フォーム初期化イベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2020年04月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_Initialize()
    '-----------------------------------------------------------------------------------------------
    g_lngTblEntFileMax = -1
    ReDim g_tblEntFile(0)
End Sub

'***************************************************************************************************
'* 処理名　：UserForm_QueryClose
'* 機能　　：フォーム閉鎖イベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    '-----------------------------------------------------------------------------------------------
    ' [×]ボタンはHideに置き換え
    If CloseMode = vbFormControlMenu Then
        Cancel = True
        Me.Hide
    End If
End Sub

'***************************************************************************************************
'* 処理名　：UserForm_Terminate
'* 機能　　：フォーム終了イベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_Terminate()
    '-----------------------------------------------------------------------------------------------
    ' サブクラス終了
    Call modDragFiles.GP_EndSubClass(0)
End Sub

'***************************************************************************************************
'   ■■■ サブ処理 ■■■
'***************************************************************************************************
'* 処理名　：GP_GetFileList
'* 機能　　：ファイル名のリスト受け取り
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2020年04月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Friend Sub GP_GetFileList()
    '-----------------------------------------------------------------------------------------------
    ' ファイルが受け取れたら終了
    If g_lngTblEntFileMax >= 0 Then
        Me.Hide
    End If
End Sub

'------------------------------------------<< End of Source >>--------------------------------------

このサンプルを転用利用されることを想定して説明すると、フォーム上にファイル名を受け取るテキストボックスを複数配置して、そのそれぞれに対してドラッグされたファイル名を表示させるという利用方法は簡単ではありません。
シート上のセルであれば「どのセルがダブルクリックされたか」は明確なので、フォームは単に「ドラッグされたファイル名を受け取る」という機能だけにしています。
このユーザーフォーム上のコードでは「GP_GetFileList」というプロシージャだけは次のサブクラス側から呼び出されるので Friendスコープとしています。作業としては、ファイルがドラッグされた時にサブクラス側から呼び出されるのでフォームを閉じるという作業になります。

最後はサブクラス動作記述のモジュール「modDragFiles」です。


'***************************************************************************************************
'   ファイル名受け取りフォーム用モジュール(共通)                    modDragFiles(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 07/09/24(2.0.0)新規作成
' 19/10/28(2.1.0)Declare記述の変更(64ビット版Excel対応)
' 20/04/18(2.2.0)64ビットとの分割コンパイル記述の見直し
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const GWL_WNDPROC As Long = -4                      ' アドレス書き換え指定
Private Const WM_DROPFILES As Long = &H233                  ' ファイルのドロップ時のメッセージ
Private Const MAX_PATH As Long = 260                        ' パス名文字列長上限
'---------------------------------------------------------------------------------------------------
#If VBA7 Then
' ウィンドウ属性を変更
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLongPtr Lib "USER32.dll" Alias "SetWindowLongPtrA" _
            (ByVal hWnd As LongPtr, _
             ByVal nIndex As Long, _
             ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function SetWindowLongPtr Lib "USER32.dll" Alias "SetWindowLongA" _
            (ByVal hWnd As LongPtr, _
             ByVal nIndex As Long, _
             ByVal dwNewLong As LongPtr) As LongPtr
    #End If
' ウィンドウプロシージャにメッセージ情報を渡す
Private Declare PtrSafe Function CallWindowProc Lib "USER32.dll" Alias "CallWindowProcA" _
    (ByVal lpPrevWndFunc As LongPtr, _
     ByVal hWnd As LongPtr, _
     ByVal Msg As Long, _
     ByVal wParam As LongPtr, _
     ByVal lParam As LongPtr) As LongPtr
' ドラッグ＆ドロップを受け入れるかを設定
Private Declare PtrSafe Sub DragAcceptFiles Lib "SHELL32.dll" _
    (ByVal hWnd As LongPtr, _
     ByVal fAccept As Long)
'ドロップされたファイルの名前を取得する
Private Declare PtrSafe Function DragQueryFile Lib "SHELL32.dll" Alias "DragQueryFileA" _
    (ByVal hDrop As LongPtr, _
     ByVal uInt As Long, _
     ByVal lpStr As String, _
     ByVal ch As Long) As Long
' システムが割り当てたメモリを解放
Private Declare PtrSafe Sub DragFinish Lib "SHELL32.dll" (ByVal hDrop As LongPtr)
#Else
' ウィンドウ属性を変更
Private Declare Function SetWindowLong Lib "USER32.dll" Alias "SetWindowLongA" _
    (ByVal hWnd As Long, _
     ByVal nIndex As Long, _
     ByVal dwNewLong As Long) As Long
' ウィンドウプロシージャにメッセージ情報を渡す
Private Declare Function CallWindowProc Lib "USER32.dll" Alias "CallWindowProcA" _
    (ByVal lpPrevWndFunc As Long, _
     ByVal hWnd As Long, _
     ByVal Msg As Long, _
     ByVal wParam As Long, _
     ByVal lParam As Long) As Long
' ドラッグ＆ドロップを受け入れるかを設定
Private Declare Sub DragAcceptFiles Lib "SHELL32.dll" _
    (ByVal hWnd As Long, _
     ByVal fAccept As Long)
'ドロップされたファイルの名前を取得する
Private Declare Function DragQueryFile Lib "SHELL32.dll" Alias "DragQueryFileA" _
    (ByVal hDrop As Long, _
     ByVal uInt As Long, _
     ByVal lpStr As String, _
     ByVal ch As Long) As Long
' システムが割り当てたメモリを解放
Private Declare Sub DragFinish Lib "SHELL32.dll" (ByVal hDrop As Long)
#End If
'---------------------------------------------------------------------------------------------------
' モジュール保持変数
#If VBA7 Then
Public g_lngHwnd As LongPtr                                         ' ウィンドウハンドル
Public g_lngPrevWndProc As LongPtr                                  ' ウィンドウProcアドレス
#Else
Public g_lngHwnd As Long                                            ' ウィンドウハンドル
Public g_lngPrevWndProc As Long                                     ' ウィンドウProcアドレス
#End If
Public g_blnSubClass As Boolean                                     ' サブクラス動作中
Public g_objUserForm As UF_EntFiles                                 ' 処理ユーザーフォーム
Public g_lngTblEntFileMax As Long                                   ' ファイルテーブル要素上限
Public g_tblEntFile() As String                                     ' ファイルテーブル

'***************************************************************************************************
'   ■■■ サブ処理 ■■■
'***************************************************************************************************
'* 処理名　：GP_StartSubClass
'* 機能　　：サブクラス開始
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = 処理ユーザーフォーム(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2019年10月28日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub GP_StartSubClass(ByRef objForm As UserForm)
    '-----------------------------------------------------------------------------------------------
   If Not g_blnSubClass Then
        ' フォーム確保
        Set g_objUserForm = objForm
        'ドラッグ&ドロップを受入れる
        Call DragAcceptFiles(g_lngHwnd, True)
        'ウィンドウプロシージャの登録
#If VBA7 Then
        g_lngPrevWndProc = SetWindowLongPtr(g_lngHwnd, GWL_WNDPROC, AddressOf FP_WindowProc)
#Else
        g_lngPrevWndProc = SetWindowLong(g_lngHwnd, GWL_WNDPROC, AddressOf FP_WindowProc)
#End If
        g_blnSubClass = True
    End If
End Sub

'***************************************************************************************************
'* 処理名　：GP_EndSubClass
'* 機能　　：サブクラス終了
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = Dummy(Integer)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub GP_EndSubClass(ByVal intDummy As Integer)
    '-----------------------------------------------------------------------------------------------
#If VBA7 Then
    Dim lngTemp As LongPtr                                          ' Work
    ' 元のウィンドウプロシージャに戻す
    lngTemp = SetWindowLongPtr(g_lngHwnd, GWL_WNDPROC, g_lngPrevWndProc)
#Else
    Dim lngTemp As Long                                             ' Work
    ' 元のウィンドウプロシージャに戻す
    lngTemp = SetWindowLong(g_lngHwnd, GWL_WNDPROC, g_lngPrevWndProc)
#End If
    'ドラッグ&ドロップを受入れない
    Call DragAcceptFiles(g_lngHwnd, False)
    g_blnSubClass = False
End Sub

'***************************************************************************************************
'* 処理名　：FP_WindowProc
'* 機能　　：ウィンドウプロシージャ
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理結果(Long)
'* 引数　　：CallWindowProcの既定
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2020年04月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
#If VBA7 Then
Public Function FP_WindowProc(ByVal hWnd As LongPtr, _
                              ByVal uMsg As Long, _
                              ByVal wParam As LongPtr, _
                              ByVal lParam As LongPtr) As LongPtr
#Else
Public Function FP_WindowProc(ByVal hWnd As Long, _
                              ByVal uMsg As Long, _
                              ByVal wParam As Long, _
                              ByVal lParam As Long) As Long
#End If
    '-----------------------------------------------------------------------------------------------
    ' ファイルドロップされたか
    If uMsg = WM_DROPFILES Then
        Dim lngFilesCnt As Long                                     ' ドラッグファイル数
        ' ドラッグされたファイル数の取得
        lngFilesCnt = DragQueryFile(wParam, -1&, vbNullString, 0)
        ' 有効ファイルがある
        If lngFilesCnt > 0 Then
            Dim objFso As FileSystemObject                          ' FileSystemObject
            Dim lngIx As Long                                       ' テーブルINDEX
            Set objFso = New FileSystemObject
            g_lngTblEntFileMax = -1
            ReDim g_tblEntFile(0)
            ' ドラッグされたファイルを巡回
            For lngIx = 0 To lngFilesCnt - 1
                Dim lngLen As Long                                  ' ファイル名文字長
                Dim strBuffer As String                             ' バッファ
                Dim strFilename As String                           ' ファイル名
                ' Bufferを確保
                strBuffer = String(MAX_PATH, Chr(0))
                ' ファイルの取得
                lngLen = DragQueryFile(wParam, lngIx, strBuffer, MAX_PATH)
                strFilename = Left$(strBuffer, InStr(1, strBuffer, Chr(0)) - 1)
                ' ファイルが実在すればテーブルに追加
                If objFso.FileExists(strFilename) Then
                    g_lngTblEntFileMax = g_lngTblEntFileMax + 1
                    ReDim Preserve g_tblEntFile(g_lngTblEntFileMax)
                    g_tblEntFile(g_lngTblEntFileMax) = strFilename
                End If
            Next lngIx
            Set objFso = Nothing
            ' ユーザーフォームのプロシージャを呼び出す(フォームを閉じさせる)
            Call g_objUserForm.GP_GetFileList
        End If
        Call DragFinish(wParam) 'メモリの開放
    End If
    ' ウィンドウプロシージャにメッセージ情報を渡す
    FP_WindowProc = CallWindowProc(g_lngPrevWndProc, hWnd, uMsg, wParam, lParam)
End Function

'------------------------------------------<< End of Source >>--------------------------------------

モジュールレベルの変数にシート側から参照している「g_tblEntFile」「g_lngTblEntFileMax」があります。
「サブクラス」というのは「ウィンドウからのメッセージに関する処理」であり、「Windows自身に造詣が深い人」以外は「扱うべきでない」というものです。私も「扱うべきでない」の方に含まれますが、今回の「ファイル名をドラッグ＆ドロップで受け取る」件に関してだけ、サンプルを頂いたり、何年も掛かって試したりでやっと実現できたものです。このサンプルは64ビット版Excelでも動作できています。

なお、このモジュールからユーザーフォームのプロシージャ「GP_GetFileList」を呼び出しています。ユーザーフォームにプロシージャ「GP_GetFileList」が必要であり、名称変更等が発生した場合はこれらの記述の変更が必要になります。