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

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