Win32APIを利用したドラッグ&ドロップ

ドラッグ&ドロップ(2)

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

ポイント

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

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

 ※対応:Excel2007以降

サンプルファイル

サンプルファイルを準備した。使用は各々の責任で。・・・Sample2_D&D.xls 44KB


サンプルコード

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

'アクティブなウィンドウのハンドルを取得
Public Declare 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

メモ

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

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

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

◆Join関数
 参照

GetActiveWindow関数

[詳細]

SetWindowLong関数

[詳細]

CallWindowProc関数

[詳細]

DragAcceptFiles関数

[詳細]

DragQueryFile関数

[詳細]

DragFinish関数

[詳細]


Excel Tips for Teachers

Copyright (C) 2009- 坂江 保 All Rights Reserved.