トップ > 備忘録 > Excel VBA:ドラッグ&ドロップ(2)

Excel VBA:ドラッグ&ドロップ(2)Win32APIを利用したドラッグ&ドロップ   2015.02.08

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

ポイント

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

SetWindowLong関数でサブクラス化。ドロップメッセージをフックする。そしてDragAcceptFiles関数を使用してドロップされたファイル名を取得。
ユーザーフォームにこれらを実装する。
※SetWindowLong関数は64bit版のOfficeに対応していない。(2015年時点)

以下のコードやサンプルファイルはExcel2010以降の32bit版を対象する。

※Excel2007に対応させるためには、コード内のPtrSafeキーワードを削除し、上書き保存、終了し、ファイルを再起動させます。

サンプルファイル

サンプルファイルを準備した。使用は各々の責任で。 ダウンロード


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

サンプルコード2015.02.08

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

'アクティブなウィンドウのハンドルを取得
Public Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As Long
'指定されたウィンドウの属性を変更
Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
                                        ByVal hwnd As Long, _
                                        ByVal nIndex As Long, _
                                        ByVal dwNewLong As Long) As Long
'指定されたウィンドウプロシージャに、メッセージ情報を渡す
Private Declare PtrSafe 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 PtrSafe Sub DragAcceptFiles Lib "shell32.dll" ( _
                                        ByVal hwnd As Long, _
                                        ByVal fAccept As Long)
'ドロップされたファイルの名前を取得する
Private Declare PtrSafe 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 PtrSafe Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long)
'//////
Private Const GWL_WNDPROC = -4 'ウィンドウプロシージャのアドレスを書き換える
Private Const WM_DROPFILES = &H233 'ファイルのドロップ時に送信されるメッセージ
Public ghWnd As Long
Public lpPrevWndProc As Long
Public bolSubClass As Boolean

Public Sub SampleForm_Show() Excel.Application.Visible = False Userform1.Show vbModeless End Sub
Public Sub StartSubClass() 'サブクラス化開始 If Not bolSubClass Then 'ドラッグ&ドロップを受入れる Call DragAcceptFiles(ghWnd, True) 'ウィンドウプロシージャの登録 lpPrevWndProc = SetWindowLong(ghWnd, GWL_WNDPROC, AddressOf WindowProc) bolSubClass = True End If End Sub
Public Sub EndSubClass() 'サブクラス化終了 Dim temp As Long '元のウィンドウプロシージャに戻す temp = SetWindowLong(ghWnd, GWL_WNDPROC, lpPrevWndProc) 'ドラッグ&ドロップを受入れない Call DragAcceptFiles(ghWnd, False) bolSubClass = False End Sub
'ウィンドウプロシージャ Public Function WindowProc(ByVal hwnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Dim i As Long, lngLen As Long, lngFilesCnt As Long 'ファイルの総数 Dim strFiles() As String 'ファイル名 Dim buf As String * 256 If uMsg = WM_DROPFILES Then 'ドロップされた 'ドラッグされたファイル数の取得 lngFilesCnt = DragQueryFile(wParam, -1&, vbNullString, 0) ReDim strFiles(lngFilesCnt - 1) '配列初期化 For i = 0 To lngFilesCnt - 1 'ファイル名の取得 buf = String(256, Chr(0)) '変数初期化'nullで埋める lngLen = DragQueryFile(wParam, i, buf, 256) 'ファイルの取得 strFiles(i) = Left$(buf, InStr(1, buf, Chr(0)) - 1) '取得結果を配列に格納 Next MsgBox Join$(strFiles, vbCrLf) Call DragFinish(wParam) 'メモリの開放 End If WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam) End Function

次に、ユーザーフォームを挿入し、フォームモジュールに以下のコードを貼り付ける。

Private Sub UserForm_Initialize()
    ghWnd = 0
End Sub

Private Sub UserForm_Activate() If ghWnd = 0 Then ghWnd = GetActiveWindow() 'ウィンドウハンドル設定 Call StartSubClass 'サブクラス化開始 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) Call EndSubClass 'サブクラス化解除 ghWnd = 0 With Excel.Application If 1 < .Workbooks.Count Then .Visible = True With .ThisWorkbook .Saved = True .Close End With Else .Visible = True .DisplayAlerts = False .Quit End If End With End Sub

実行

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


メモ

AppActivate ステートメント

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

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

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

Join関数

参照

GetActiveWindow関数

[詳細]

SetWindowLong関数

[詳細]

CallWindowProc関数

[詳細]

DragAcceptFiles関数

[詳細]

DragQueryFile関数

[詳細]

DragFinish関数

[詳細]


ページトップへ戻る
Copyright(C) 2009- 坂江 保 All Rights Reserved.