VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています(切り貼りとも言います)。
  1. ホーム
  2. Other
  3. dandd2textbox


UserFormのTextBoxにファイルをドロップ(疑似)

UserFormのTextBoxにエクスプローラ等からファイルをドラッグアンドドロップするのにトライしてみました。
VBAのTextBoxはハンドルが取得できないので、サブクラス化が出来ません。他の記事で行った、UserFormで受けたマウス操作のイベントで、
コントロールを操作する事で、みかけ上、コントロールでイベントが発生した様にする方法を応用してみました。


'☆Module1

'UserFormからDropしたファイルパスを受け取る
Public filePath1 As String
Public filePath2 As String

Sub showForm()
  'modelessはVBAの処理が追いつかずNG
  UserForm1.Show
  
  Debug.Print filePath1, filePath2
  
End Sub

'☆Module2

'AddressOfが使えるのは標準モジュールのプロシージャのみ。

'マクロ一覧で表示されなくする
Option Private Module
 
Public Type POINTAPI
    x As Long
    y As Long
End Type

Public Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

'指定されたウィンドウプロシージャに、メッセージ情報を渡します
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'指定されたウィンドウの属性を変更
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'ウィンドウがファイルのドラッグアンドドロップを受け入れるかどうかを設定
Public Declare Sub DragAcceptFiles Lib "Shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
'ドラッグアンドドロップ操作が成功した場合、ドロップされたファイルの名前を取得する
Public Declare 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
'アプリケーションへファイル名を転送するためにシステムが割り当てたメモリを解放
Public Declare Sub DragFinish Lib "Shell32.dll" (ByVal hDrop As Long)
'ファイルがドラッグ・アンド・ドロップされたときのマウスポインタの位置を取得
Public Declare Function DragQueryPoint Lib "Shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long
'ActiveWindowのハンドル取得 UserFormのハンドル取得に使用
Public Declare Function GetActiveWindow Lib "user32" () As Long

Public Const WM_DROPFILES = &H233
Public Const GWL_WNDPROC = -4

'必要によりDPIはWindows APIで取得の事
Public Const DPI As Long = 96
Public Const PPI As Long = 72

Public IsHooked      As Boolean
Public lpPrevWndProc As Long
'UserFormのハンドル
Public m_hwnd         As Long

'Userformと共用する動的配列
Public myTextBox() As MSForms.TextBox
Public myRect() As RECT

'DropされたScreen座標を保持
Dim pScrn   As POINTAPI

'----------------------------------------------------------------
'ウィンドウプロシージャ
'----------------------------------------------------------------
Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hDrop   As Long
    Dim filecnt As Long         'ファイルの総数
    Dim files() As String       'ファイル名
    Dim i       As Long
    Dim leng    As Long
    Dim buf     As String * 256
    Dim pDrop   As POINTAPI
    Dim lngRet As Long
    
    On Error Resume Next 'フリーズ防止に必要
    Select Case uMsg
        Case WM_DROPFILES   'ドロップされた
            '---------------------------------------
            'ドラッグされたファイルの格納
            '---------------------------------------
            hDrop = wParam
            'ドラッグされたファイル数の取得
            filecnt = DragQueryFile(hDrop, -1&, vbNullString, 0)
            'ドロップされた位置の取得
            Call DragQueryPoint(hDrop, pDrop)
            pScrn = pDrop
            
            '配列初期化
            ReDim files(filecnt - 1)
            'ファイル名の取得
            For i = 0 To filecnt - 1
                '変数初期化
                buf = String(256, Chr(0))   'nullで埋める
                'ファイルの取得
                leng = DragQueryFile(hDrop, i, buf, 256)
                '取得結果を配列に格納
                files(i) = Left$(buf, InStr(1, buf, Chr(0)) - 1)
            Next
            'ファイルドロップした座標から該当TextBoxを取得して値を設定
            lngRet = getTextBoxNo
            If lngRet > 0 Then myTextBox(lngRet).Value = files(0)
            
            'メモリの開放
            Call DragFinish(hDrop)
          
        Case Else
    End Select
    '他の処理はデフォルトのウィンドウプロシージャに委ねる
    WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam)
End Function

'----------------------------------------------------------------
'サブクラス化開始
' Publicにしないと、UserFormから参照できない
'----------------------------------------------------------------
Public Sub Hook()
    If IsHooked Then
        MsgBox "Don't hook it twice without " & _
            "unhooking, or you will be unable to unhook it."
    Else
        '受け入れの有
        Call DragAcceptFiles(m_hwnd, True)
        'ウィンドウプロシージャの登録
        lpPrevWndProc = SetWindowLong(m_hwnd, GWL_WNDPROC, AddressOf WindowProc)
        IsHooked = True
    End If
End Sub

'----------------------------------------------------------------
'サブクラス化解除
'----------------------------------------------------------------
Public Sub Unhook()
    Dim temp As Long

    '元のウィンドウプロシージャに戻す
    temp = SetWindowLong(m_hwnd, GWL_WNDPROC, lpPrevWndProc)
    '受け入れの無
    Call DragAcceptFiles(m_hwnd, True)
    IsHooked = False
End Sub

'マウスの位置のテキストボックスのNoを取得。失敗すると0を戻す。
Private Function getTextBoxNo() As Long
  Dim i As Long
  
  'RECT配列内の値はUserForm座標→Client座標に変換済み。
  For i = 1 To UBound(myRect)
    With myRect(i)
      If (pScrn.x >= .Left) And (pScrn.x <= .Right) And (pScrn.y >= .Top) And (pScrn.y <= .Bottom) Then
        getTextBoxNo = i
        Exit Function
      End If
    End With
  Next i
  getTextBoxNo = 0

End Function

'☆UserForm1
'TextBox2個と、CommandButton1個を配置

Private Sub UserForm_Initialize()
  Dim myControl As Control
  Dim scaleFactor As Single
  
  scaleFactor = DPI / PPI
  '配列の添え字0の要素は使わない
  ReDim myTextBox(0 To 0)
  ReDim myRect(0 To 0)
  
  'TextBoxの座標をRECT構造体に保存
  For Each myControl In Me.Controls
    If TypeName(myControl) = "TextBox" Then
      ReDim Preserve myTextBox(0 To UBound(myTextBox) + 1)
      ReDim Preserve myRect(0 To UBound(myRect) + 1)
      
      Set myTextBox(UBound(myTextBox)) = myControl
      With myRect(UBound(myRect))
        .Left = CLng(myControl.Left * scaleFactor)
        .Top = CLng(myControl.Top * scaleFactor)
        .Right = CLng((myControl.Left + myControl.Width) * scaleFactor)
        .Bottom = CLng((myControl.Top + myControl.Height) * scaleFactor)
      End With
    End If
  Next

End Sub

Private Sub UserForm_Activate()
  'GetActiveWindowはInitialize中だと失敗。FindWindowならOK。
  m_hwnd = GetActiveWindow()
  'UserFormがDropを受け付ける様に設定
  Call DragAcceptFiles(m_hwnd, True)
  'フック
  Hook
End Sub


Private Sub CommandButton1_Click()
  Unhook
  
  filePath1 = Me.TextBox1.Value
  filePath2 = Me.TextBox2.Value
  
  Unload Me

End Sub


'以下は念のため
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  On Error Resume Next
  Unhook
End Sub

Private Sub UserForm_Terminate()
  On Error Resume Next
  Unhook
End Sub