Fichiers formulaire utilisateur Excel Glisser & Déposer

Question

Je voudrais implémenter un objet glisser & glisser sur un formulaire utilisateur dans Excel 2016. Le but est de permettre de glisser & Déposer des fichiers (à partir de Windows Files Explorer) sur l'utilisateur Excel Formulaire, et attraper l'événement drop pour extraire le fichier (s) chemin et les noms. Jusqu'ici, j'ai trouvé que c'était réalisable avec un contrôle très ancien qui n'est plus fourni ces dernières années par Microsoft - le contrôle Treeview. Ce contrôle fonctionne parfaitement pour mon besoin, cependant, nécessite une inscription spéciale sur un ancien OCX et un fichier TLB qui ne sont pas communs sur les machines d'exécution des utilisateurs standard, ne sont pas communs (et fonctionnant) leurs outils d'enregistrement, tels que Regtlibv12/Regtlib sur le nouveau Windows 10 avec Office 2016 64bit.

Je me demande - est-il possible que Microsoft n'offre aucun contrôle à cela au cours des dernières années? Savez-vous si cela est réalisable avec les offres standard Windows 10 et Office 2016 64 bits?

Answer 1

Vous pouvez le faire en accrochant le userform, et en utilisant l'API Windows I du code de adapté Here

RemarqueCet copyright:

'Ce code a été écrit par Dev Ashish. 'Il ne doit pas être modifié ou distribué, ', sauf dans le cadre d'une application. 'Vous êtes libre de l'utiliser dans n'importe quelle application, ' à condition que l'avis de droits d'auteur reste inchangé. ' ' Code de l'aimable autorisation de Dev Ashish

(Bien que je l'ai adapté certaines d'entre elles) Dans le userform, mettre ce code:

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 

La fonction sDragDrop met la liste des fichiers à un messagebox, mais vous pouvez définir une variable pour le stocker.

Bien sûr, comme il s'agit d'accrocher la fenêtre, il y a un risque pour la stabilité!