- ホーム
- Other
- 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