Question

我想在Excel 2016中的用户表单上实现Drag＆amp; Drop对象。目的是允许拖放文件（从Windows文件资源管理器）到Excel用户窗体，并捕获放置事件以提取文件路径和名称。

到目前为止，我发现它可以通过微软最近几年不再提供的非常旧的控件实现 - Treeview控件。这个控件非常适合我的需要，但是，需要对旧的OCX和TLB文件进行特殊注册，这在标准用户的运行时机器上并不常见，而不是常用（和工作）他们的注册工具，例如Regtlibv12 / Regtlib在新的Windows 10上使用Office 2016 64位。

我想知道 - 近年来微软是否可能无法对此进行控制？您知道这是否可以通过标准的Windows 10和Office 2016 64位产品实现吗？

Answer 1

您可以通过挂钩userform并使用Windows API来完成此操作我修改了Here

中的一些代码

请注意此版权：

＆＃39;此代码最初由Dev Ashish编写。＆＃39;不得更改或分发，＆＃39;除了作为申请的一部分。＆＃39;您可以在任何应用程序中自由使用它，＆＃39;如果版权声明保持不变。＆＃39; ＆＃39;代码礼貌＆＃39; Dev Ashish

（虽然我已经改编了一些）在userform中，输入以下代码：

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal 
lpClassName As String, ByVal lpWindowName As String) As Long

Function hWnd() As Long
Dim hWndThis As Long
If Val(Application.Version) > 8 Then
    hWndThis = FindWindow(lpClassName:="ThunderDFrame", lpWindowName:=Me.Caption)
Else
    hWndThis = FindWindow(lpClassName:="ThunderXFrame", lpWindowName:=Me.Caption)
End If
hWnd = hWndThis
End Function

Private Sub UserForm_Initialize()
Call sEnableDrop(Me, hWnd)
Call sHook(hWnd)
End Sub

Private Declare Function apiCallWindowProc 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

Private Declare Function apiSetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal wNewWord As Long) _
As Long

Private Declare Function apiGetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) _
As Long

Private Declare Sub sapiDragAcceptFiles Lib "shell32.dll" _
Alias "DragAcceptFiles" _
(ByVal hWnd As Long, _
ByVal fAccept As Long)

Private Declare Sub sapiDragFinish Lib "shell32.dll" _
Alias "DragFinish" _
(ByVal hDrop As Long)

Private Declare Function apiDragQueryFile Lib "shell32.dll" _
Alias "DragQueryFileA" _
(ByVal hDrop As Long, _
ByVal iFile As Long, _
ByVal lpszFile As String, _
ByVal cch As Long) _
As Long

Private lpPrevWndProc  As Long
Private Const GWL_WNDPROC  As Long = (-4)
Private Const GWL_EXSTYLE = (-20)
Private Const WM_DROPFILES = &H233
Private Const WS_EX_ACCEPTFILES = &H10&
Private hWnd_Frm As Long

Sub sDragDrop(ByVal hWnd As Long, _
                        ByVal Msg As Long, _
                        ByVal wParam As Long, _
                        ByVal lParam As Long)

Dim lngRet As Long, strTmp As String, intLen As Integer
Dim lngCount As Long, i As Long, strOut As String
Const cMAX_SIZE = 50
On Error Resume Next
If Msg = WM_DROPFILES Then
    strTmp = String$(255, 0)
    lngCount = apiDragQueryFile(wParam, &HFFFFFFFF, strTmp, Len(strTmp))
    For i = 0 To lngCount - 1
        strTmp = String$(cMAX_SIZE, 0)
        intLen = apiDragQueryFile(wParam, i, strTmp, cMAX_SIZE)
        strOut = strOut & Left$(strTmp, intLen) & ";"
    Next i
    strOut = Left$(strOut, Len(strOut) - 1)
    Call sapiDragFinish(wParam)
    MsgBox strOut

Else
    lngRet = apiCallWindowProc( _
                        ByVal lpPrevWndProc, _
                        ByVal hWnd, _
                        ByVal Msg, _
                        ByVal wParam, _
                        ByVal lParam)
End If
End Sub

Sub sEnableDrop(frm As UserForm, hWnd As Long)
Dim lngStyle As Long, lngRet As Long
lngStyle = apiGetWindowLong(hWnd, GWL_EXSTYLE)
lngStyle = lngStyle Or WS_EX_ACCEPTFILES
lngRet = apiSetWindowLong(hWnd, GWL_EXSTYLE, lngStyle)
Call sapiDragAcceptFiles(hWnd, True)
hWnd_Frm = hWnd
End Sub


Sub sHook(hWnd As Long)
lpPrevWndProc = apiSetWindowLong(hWnd, GWL_WNDPROC, AddressOf sDragDrop)
End Sub

Sub sUnhook(hWnd As Long)
Dim lngTmp As Long
lngTmp = apiSetWindowLong(hWnd, GWL_WNDPROC, lpPrevWndProc)
lpPrevWndProc = 0
End Sub

sDragDrop函数将文件列表放入消息框，但您可以设置一个变量来存储它。

当然，因为它正在挂窗，所以这是稳定的风险！

Excel用户表单文件拖放降

1 个答案: