Excel VBA：ドラッグ＆ドロップ（2）

Excel VBA：ドラッグ＆ドロップ（2）Win32APIを利用したドラッグ＆ドロップ　2015.02.08　［更新日］2024.12.28

Win32APIを利用したドラッグ＆ドロップで、ファイルパスを取得するためのコードとメモです。
次のサイトを参考にさせていただきました。
出典：~~Accessむかむか - ファイルのドラッグ&ドロップ~~（サイトは終了したようです）

64bit版のExcelでも動作するようにしています。

ポイント

・GetActiveWindow関数(Win32API)
・SetWindowLong関数(Win32API)
・CallWindowProc関数(Win32API)
・DragAcceptFiles関数(Win32API)
・DragQueryFile関数(Win32API)
・DragFinish関数(Win32API)

SetWindowLong関数でサブクラス化し、ドロップメッセージをフックする。
そして DragAcceptFiles 関数を使用してドロップされたファイル名を取得。
ユーザーフォームにこれらを実装する。

サンプルファイル

ユーザーフォームにドラッグしたファイルのフルパスを取得するサンプルファイル
　ダウンロード

【お薦め】マクロ・プロシージャを管理する無料のツール！
　Excelマクロ管理ツール

サンプルコード2015.02.08　　　［更新日］2024.12.28

まず、標準モジュールに以下のコードを貼り付ける。

' ***（宣言セクションに記述）***  Excel2010以降対応
'-------------------------------------
' Win32API
'-------------------------------------
'《アクティブなウィンドウのウィンドウハンドルを取得》
' https://learn.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-getactivewindow
Public Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As LongPtr

'《指定したウィンドウの属性を変更》
#If Win64 Then ' 64bit版
    ' https://learn.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-setwindowlongptra
    Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongPtrA" ( _
                                            ByVal hWnd As LongPtr, _
                                            ByVal nIndex As Long, _
                                            ByVal dwNewLong As LongPtr) As LongPtr
#Else
    ' https://learn.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-setwindowlonga
    Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
                                            ByVal hWnd As LongPtr, _
                                            ByVal nIndex As Long, _
                                            ByVal dwNewLong As LongPtr) As LongPtr
#End If

'《指定したウィンドウ プロシージャにメッセージ情報を渡す》
' https://learn.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-callwindowproca
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

'《ウィンドウがドロップされたファイルを受け入れるかどうかを登録》
' https://learn.microsoft.com/ja-jp/windows/win32/api/shellapi/nf-shellapi-dragacceptfiles
Private Declare PtrSafe Sub DragAcceptFiles Lib "shell32.dll" ( _
                                        ByVal hWnd As LongPtr, _
                                        ByVal fAccept As Long)

'《ドロップされたファイルの名前を取得》
' https://learn.microsoft.com/ja-jp/windows/win32/api/shellapi/nf-shellapi-dragqueryfilea
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

'《アプリケーションへファイル名を転送するためにシステムが割り当てたメモリを解放》
' https://learn.microsoft.com/ja-jp/windows/win32/api/shellapi/nf-shellapi-dragfinish
Private Declare PtrSafe Sub DragFinish Lib "shell32.dll" ( _
                                        ByVal hDrop As LongPtr)

'-------------------------------------
' 定数（モジュールレベル）
'-------------------------------------
' SetWindowLong 関数のパラメーター
Private Const GWL_WNDPROC  As Long = -4     ' ウィンドウ プロシージャの新しいアドレスを設定する

Private Const WM_DROPFILES As Long = &H233  ' ユーザーがファイルをドロップしたときに送信されるメッセージID

'-------------------------------------
' 変数（モジュールレベル）
'-------------------------------------
Private lpPrevWndProc As LongPtr            ' Windowプロシージャ代入用
Private blnSubClass   As Boolean            ' サブクラス状態フラグ
' ***（ここまで）***

'-----------------------------------------------------------------
' ドラッグ & ドロップ 用フォーム表示
'-----------------------------------------------------------------
'［作成日］2015.02.08　［更新日］2024.12.28
' https://excel.syogyoumujou.com/memorandum/d_and_d_2.html
'-----------------------------------------------------------------
Public Sub SampleForm_Show()
    Application.WindowState = xlMinimized
    UserForm1.Show vbModeless
End Sub

'-----------------------------------------------------------------
' サブクラス開始
'-----------------------------------------------------------------
'［引数］
'   hdlWindow：対象のウィンドウハンドル
'［作成日］2015.02.08　［更新日］2024.12.28
' https://excel.syogyoumujou.com/memorandum/d_and_d_2.html
'-----------------------------------------------------------------
Public Sub startSubClass(ByVal hdlWindow As LongPtr)
    If Not blnSubClass Then
        '《ウィンドウがドロップされたファイルを受け入れるかどうかを登録》
        ' ・ 引数1：対象のウィンドウハンドル
        ' ・ 引数2：対象ウィンドウがドロップされたファイルを受け入れるかの設定
        '           True：ファイルを受け入れる False：ファイルを受け入れない
        Call DragAcceptFiles(hdlWindow, True)
        
        '《指定したウィンドウの属性を変更》
        ' ・ 引数1：ウィンドウのハンドル
        ' ・ 引数2：設定する値への 0 から始まるオフセット
        ' ・ 引数3：置換値
        ' 戻り値  ：関数が成功した場合、戻り値は指定したオフセットの前の値
        '           関数が失敗した場合、戻り値は 0
        lpPrevWndProc = SetWindowLong(hdlWindow, GWL_WNDPROC, AddressOf WindowProcedure) ' ウィンドウプロシージャの登録
        
        If lpPrevWndProc <> 0 Then blnSubClass = True
    End If
End Sub

'-----------------------------------------------------------------
' サブクラス終了
'-----------------------------------------------------------------
'［引数］
'   hdlTargetWindow：対象のウィンドウハンドル
'［作成日］2015.02.08　［更新日］2024.12.28
' https://excel.syogyoumujou.com/memorandum/d_and_d_2.html
'-----------------------------------------------------------------
Public Sub endSubClass(ByVal hdlWindow As LongPtr)
    Dim tmp As LongPtr
    '《指定したウィンドウの属性を変更》
    tmp = SetWindowLong(hdlWindow, GWL_WNDPROC, lpPrevWndProc)  ' 元のプロシージャに戻す
    
    '《ウィンドウがドロップされたファイルを受け入れるかどうかを登録》
    Call DragAcceptFiles(hdlWindow, False)                      ' ドラッグ&ドロップを受け入れない
    blnSubClass = False
End Sub

'-----------------------------------------------------------------
' 登録用ウィンドウプロシージャ
'-----------------------------------------------------------------
'［引数・戻り値］
'   ※プロシージャ内
'     《指定したウィンドウ プロシージャにメッセージ情報を渡す》を参照
'［作成日］2015.02.08　［更新日］2024.12.28
' https://excel.syogyoumujou.com/memorandum/d_and_d_2.html
'-----------------------------------------------------------------
Public Function WindowProcedure(ByVal hWnd As LongPtr, _
                                ByVal uMsg As Long, _
                                ByVal wParam As LongPtr, _
                                ByVal lParam As LongPtr) As LongPtr
    ' メッセージ判定
    If uMsg = WM_DROPFILES Then 'ドロップされた場合
    
        '-------------------------------------
        ' ドロップされたファイル数取得
        '-------------------------------------
        Dim lngNumberOfFiles As Long
        '《ドロップされたファイルの名前を取得》
        ' ・ 引数1：ドロップされたファイルのファイル名を含む構造体の識別子
        ' ・ 引数2：クエリを実行するファイルのインデックス
        '           0xFFFFFFFF （32bitでは-1）の場合は戻り値にファイル数が返る
        ' ・ 引数3：ドロップされたファイルのファイル名を受け取るバッファーのアドレス
        ' ・ 引数4：引数3のバッファーサイズ
        ' 戻り値  ： 0 以外は成功　引数2が 0xFFFFFFFF（-1） の場合ファイル数
        lngNumberOfFiles = DragQueryFile(wParam, -1&, vbNullString, 0)      ' ファイル数取得
        
        ' ドロップファイルが 1 未満の場合は抜ける
        If lngNumberOfFiles < 1 Then Exit Function

        '-------------------------------------
        ' ドロップされたファイル名取得
        '-------------------------------------
        ' ファイル数分の配列を生成
        Dim strFileName() As String
        ReDim strFileName(lngNumberOfFiles - 1)
        
        Dim i             As Long
        Dim lngLen        As Long
        Dim strBuf        As String * 256

        For i = 0 To lngNumberOfFiles - 1
            ' バッファを 値 0 を持つ文字※ で埋める（※ vbNullChar）
            strBuf = String(256, Chr(0))
            
            '《ドロップされたファイルの名前を取得》
            ' ※ strBuf にファイル名が設定される
            lngLen = DragQueryFile(wParam, i, strBuf, Len(strBuf))
            
            ' 取得したファイル名の不要な 値 0 を持つ文字 を置換し配列に設定
            strFileName(i) = Replace$(strBuf, Chr(0), "")
        Next

        '《アプリケーションへファイル名を転送するためにシステムが割り当てたメモリを解放》
        ' ・ 引数1：ドロップされたファイルのファイル名を含む構造体の識別子
        Call DragFinish(wParam)

        ' ファイルパス表示
        MsgBox Join$(strFileName, vbLf)

    End If

    '《指定したウィンドウ プロシージャにメッセージ情報を渡す》
    ' ・ 引数1：前のウィンドウ プロシージャ
    ' ・ 引数2：メッセージを受信するウィンドウ プロシージャのハンドル
    ' ・ 引数3：メッセージ
    ' ・ 引数4：追加のメッセージ固有の情報 引数3のパラメーターによって異なる
    ' ・ 引数5：追加のメッセージ固有の情報 引数3のパラメーターによって異なる
    ' 戻り値  ：メッセージ処理の結果を指定 送信されたメッセージに依存する
    WindowProcedure = CallWindowProc(lpPrevWndProc, hWnd, uMsg, wParam, lParam)
End Function

次に、ユーザーフォームを挿入し、フォームモジュールに以下のコードを貼り付ける。
フォームの名前は「UserForm1」とする。

'-------------------------------------
' 定数（モジュールレベル）
'-------------------------------------
Private hdlTargetWindow As LongPtr ' 対象ウィンドウハンドル

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    hdlTargetWindow = 0
End Sub

Private Sub UserForm_Activate()
    If hdlTargetWindow = 0 Then
        '《アクティブなウィンドウのウィンドウハンドルを取得》
        hdlTargetWindow = GetActiveWindow()
        
        '《サブクラス開始》
        ' ・ 引数1：対象のウィンドウハンドル
        Call startSubClass(hdlTargetWindow)
    End If
End Sub

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

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    '《サブクラス終了》
    ' ・ 引数1：対象のウィンドウハンドル
    Call endSubClass(hdlTargetWindow)
    
    Application.WindowState = xlMaximized
End Sub

実行

標準モジュールの「SampleForm_Show」を実行するとフォームが表示される。
そのフォームにファイルをドラッグ＆ドロップすると、ファイルパスが取得される。

メモ

AppActivate ステートメント

アプリケーションウィンドウをアクティブする。
構文：AppActivate title[, wait]

[ title ]
必ず指定。アクティブにするアプリケーションウィンドウのタイトルを表す文字列式を指定。
Shell 関数によって返されるタスク ID を指定することも可能。

[ wait ]
省略可能。アプリケーションをアクティブにする前に呼び出し側のアプリケーションに
フォーカスを持たせるかどうかをBooleanの値で設定。
False・・・既定値。呼び出し側のアプリケーションがフォーカスを持っていなくても、指定したアプリケーションをアクティブにする。
True・・・呼び出し側のアプリケーションがフォーカスを持つまで待機し、指定したアプリケーションをアクティブにする。

Join関数

参照

GetActiveWindow関数

[詳細]

SetWindowLong関数

［参考］Microsoft Learn Challenge SetWindowLongA 関数 (winuser.h)
　　　　Microsoft Learn Challenge SetWindowLongPtrA 関数 (winuser.h)

CallWindowProc関数

［参考］Microsoft Learn Challenge CallWindowProcW 関数 (winuser.h)

DragAcceptFiles関数

［参考］Microsoft Learn Challenge DragAcceptFiles 関数 (shellapi.h)

DragQueryFile関数

［参考］Microsoft Learn Challenge DragQueryFileA 関数 (shellapi.h)

DragFinish関数

［参考］Microsoft Learn Challenge DragFinish 関数 (shellapi.h)

トップ　>　備忘録　>　Excel VBA：ドラッグ＆ドロップ（2）