HOME > エクセルVBA > サンプル > DragFileForm

DragFileForm


【ファイル名】DragFileForm.xlsm
【バージョン】Ver 1.0.0.3
【作成日】2019年04月23日
【更新日】2022年07月09日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】DragFileForm.zip
【説明】エクスプローラーからUserFormにファイルをドラッグ&ドロップするサンプルです。

メニュー

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="フォームの表示">
          <button id="ShowFormButton" label="ドラッグ&ドロップ" keytip="D"
                  supertip="ドラッグ&ドロップのフォームを表示します。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

Module1
Option Explicit

#If Win64 Then
  ' https://docs.microsoft.com/en-us/windows/desktop/api/winuser/nf-winuser-callwindowprocw
  Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shellapi/nf-shellapi-dragqueryfilew
  Private Declare PtrSafe Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileW" (ByVal hDrop As LongPtr, ByVal UINT As Long, ByVal lpStr As LongPtr, ByVal ch As Long) As Long
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shellapi/nf-shellapi-dragfinish
  Private Declare PtrSafe Sub DragFinish Lib "shell32.dll" (ByVal hDrop As LongPtr)
  ' https://docs.microsoft.com/en-us/windows/desktop/api/winuser/nf-winuser-setforegroundwindow
  Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
#Else
  Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileW" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As Long, ByVal ch As Long) As Long
  Private Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long)
  Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
#End If

Public Const MAX_PATH = 260& ' パス名の文字の最大数
Private Const WM_DROPFILES = &H233 ' ドラッグ&ドロップ

#If Win64 Then
  Public lpPrevWndProc As LongPtr ' WndProcを後で戻すために記憶する
#Else
  Public lpPrevWndProc As Long
#End If
Private rbRibbonUI As IRibbonUI   ' リボン

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' ボタンの処理
  DragFileForm.Show vbModal
End Sub

' Windowsのメッセージを処理します。
#If Win64 Then
Public Function WindowProc(ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
Public Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
  Dim i As Long
  Dim Cnt As Long
  Dim FileName As String
  
  If Msg = WM_DROPFILES Then
    Cnt = DragQueryFile(wParam, -1&, StrPtr(vbNullString), 0) ' ファイルの総数を取得する
    For i = 0 To Cnt - 1 ' Windows APIなので、0から開始する
      FileName = String(MAX_PATH, vbNullChar)
      Call DragQueryFile(wParam, i, StrPtr(FileName), MAX_PATH) ' i番目のファイルのパス名を取得する
      FileName = StrVBA(FileName) ' ヌルで終わる文字列から、vbNullCharの左側の文字列を取得します。
      DragFileForm.ListBox1.AddItem FileName
    Next
    Call DragFinish(wParam) ' ドラッグ&ドロップを終了する
    SetForegroundWindow hwnd ' ウィンドウを前面に移動しアクティブにする
  End If
  
  WindowProc = CallWindowProc(lpPrevWndProc, hwnd, Msg, wParam, lParam)
End Function

' 指定したヌルで終わる文字列から、vbNullCharの左側の文字列を取得します。
Private Function StrVBA(ByVal EndNullString As String) As String
  Dim p As Long
  
  p = InStr(1, EndNullString, vbNullChar)
  If p > 0 Then
    StrVBA = Left(EndNullString, p - 1)
  Else
    StrVBA = EndNullString ' ■ vbNullCharがない場合は引数をそのまま返します。
'    StrVBA = vbNullString ' ■ 必要に応じて変更してください。
  End If
End Function
このページの上

DragFileForm
Option Explicit

#If Win64 Then
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shellapi/nf-shellapi-dragacceptfiles
  Private Declare PtrSafe Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As LongPtr, ByVal fAccept As Long)
  ' https://docs.microsoft.com/en-us/windows/desktop/api/winuser/nf-winuser-setwindowlongptrw
  Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrW" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
  ' https://docs.microsoft.com/en-us/windows/desktop/api/oleacc/nf-oleacc-windowfromaccessibleobject
  Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As LongPtr) As Long
#Else
  Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
  Private Declare Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As Long) As Long
#End If

Private Const GWL_WNDPROC = -4& 'ウィンドウ プロシージャの変更

#If Win64 Then
  Private myHwnd As LongPtr
#Else
  Private myHwnd As Long
#End If

Public Property Get hwnd()
  WindowFromAccessibleObject Me, myHwnd ' フォームのハンドルを取得する
  hwnd = myHwnd
End Property

Private Sub CloseBtn_Click() ' 「閉じる」ボタンの処理
  Unload Me
End Sub

Private Sub UserForm_Initialize() ' 初期処理
  Call DragAcceptFiles(hwnd, True) ' ドラッグ&ドロップを許可する
  lpPrevWndProc = SetWindowLongPtr(hwnd, GWL_WNDPROC, AddressOf WindowProc) ' AddressOfで取得した標準モジュールのプロシージャーにWindowProcを変更する
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) ' 終了処理
  Call SetWindowLongPtr(hwnd, GWL_WNDPROC, lpPrevWndProc) ' WindowProcを元に戻す
  Call DragAcceptFiles(hwnd, False) ' ドラッグ&ドロップを許可しない
End Sub
このページの上