DragDrop trên Office 64bit

tuhocvba

Administrator
Thành viên BQT
Nếu nói phiên bản Office nào có nhiều tính năng tiện lợi, câu trả lời là Office 32bit.
Tôi lấy ví dụ, các bạn có ListView trên Office 32bit nhưng Office 64bit thì không. Hoặc TreeView có trên Office 32bit nhưng trên Office64 bit thì không.

Tôi đặc biệt quan tâm tới DragDrop bởi vì đây là tính năng rất tiện lợi. Dịch ra tiếng việt đó là tính năng kéo thả.
Thay vì phải ấn nút select chọn file, bạn chỉ cần thực hiện thao tác kéo thả. Quả nhiên là rất tiện lợi.
Tôi ví dụ tôi có một ô TextBox trên UserForm (File excel A) dùng để nhận đường link một file. Tôi sẽ thực hiện thao tác kéo thả (DragDrop) một file excel B -kéo nó thả vào ô Textbox, mong muốn là ô TextBox sẽ nhận link file excel B.
Bạn cần đăng nhập để thấy đính kèm

DragDrop có trên ListView, nhưng ListView lại chỉ có trên Office 32bit.
Và topic này sẽ hiện thực hóa DragDrop trên Office 64bit, mà ở đây chúng tôi đã test thành công với ô TextBox.
(còn nữa)
Dự án DragDrop cho office 64bit-Admin tuhocvba & Euler.
 

Euler

Mod
Thành viên BQT
Đã test trên Office 2016 32bit Win 10, Office 2013 64bit Win7: Hoạt động tốt.

Key Parts của Drag&Drop là IDropTarget.
Chỉ cần gọi được IDropTarget thì ta có thể thực hiện kéo thả.
Vậy, sau đây chúng ta sẽ đăng ký thuộc tính Window cho UserForm thông qua hàm RegisterDragDrop.
Sau đó chúng ta sẽ thực hiện lấy File name thông qua động tác kéo thả như mô tả ở .

Code trên Module:
Mã:
'--------------------------------------------------------------------
'Website: https://tuhocvba.net/threads/dragdrop-tren-office-64bit.700/#post-3958
'Tham khao: http://www.excel.studio-kazu.jp/kw/20181211140007.html
'
'Admin tuhocvba & Euler website tuhocvba.net da kiem tra va test thu OK
'====================================================================
Public Type TDragDrop
     pfn As LongPtr
     fn(6) As LongPtr
     rt(3) As Long
     hClient As LongPtr
     ctl As IControl
End Type
Private Const E_NOTIMPL = &H80004001
Private Const E_NOINTERFACE = &H80004002
Private Const GA_ROOT = 2&
Private Const GW_CHILD = 5&
#If Win64 Then
Private Const PTR_GAP = 8&
Private Declare PtrSafe Function PtInRect& Lib "User32" _
     (ByVal lprc As LongPtr, _
      ByVal pt As LongPtr)
#Else
Private Const PTR_GAP = 4&
Private Declare PtrSafe Function PtInRect& Lib "User32" _
     (ByVal lprc As LongPtr, _
      ByVal ptX As Long, ByVal ptY As Long)
#End If
Private Declare PtrSafe Sub MoveMemory Lib "Kernel32" Alias "RtlMoveMemory" _
     (Destination As Any, _
      Source As Any, _
      Optional ByVal Length As Long = PTR_GAP)
Private Declare PtrSafe Function RegisterDragDrop& Lib "Ole32" _
     (ByVal Hwnd As LongPtr, _
      ByVal pDropTarget As LongPtr)
Private Declare PtrSafe Function RevokeDragDrop& Lib "Ole32" _
     (ByVal Hwnd As LongPtr)
Private Declare PtrSafe Function SHGetIDListFromObject& Lib "Shell32" _
     (ByVal pUnk As LongPtr, _
      ByRef ppidl As LongPtr)
Private Declare PtrSafe Function SHGetPathFromIDListW& Lib "Shell32" _
     (ByVal pidl As LongPtr, _
      ByVal pszPath As LongPtr)
Private Declare PtrSafe Function IUnknown_GetWindow& Lib "Shlwapi" Alias "#172" _
     (ByVal pUnk As LongPtr, _
      ByRef phwnd As LongPtr)
Private Declare PtrSafe Function GetAncestor Lib "User32" _
     (ByVal Hwnd As LongPtr, _
      ByVal gaFlags As Long) As LongPtr
Private Declare PtrSafe Function GetWindow Lib "User32" _
     (ByVal Hwnd As LongPtr, _
      ByVal uCmd As Long) As LongPtr
Public Sub InitDragDrop(This As TDragDrop, ByVal ctl As IControl)
     Dim buf As Object
     With This
         'Tu tao IDropTarget Interface
         .pfn = VarPtr(.fn(0))
         MoveMemory .fn(0), AddressOf QI
         MoveMemory .fn(1), AddressOf AR
         .fn(2) = .fn(1)
         MoveMemory .fn(3), AddressOf DragEnter
         MoveMemory .fn(4), AddressOf DragOver
         MoveMemory .fn(5), AddressOf DragLeave
         MoveMemory .fn(6), AddressOf Drop
         Set .ctl = ctl: Set buf = ctl
         Do
             IUnknown_GetWindow ObjPtr(buf), .hClient
             If .hClient Then Exit Do
             Set buf = buf.Parent
         Loop
         If GetAncestor(.hClient, GA_ROOT) = .hClient Then
             .hClient = GetWindow(.hClient, GW_CHILD)
         End If
         RegisterDragDrop .hClient, VarPtr(.pfn)
     End With
End Sub
Public Sub TerminateDragDrop(This As TDragDrop)
     With This
         If .hClient = 0 Then Exit Sub
         RevokeDragDrop .hClient
     End With
End Sub
Private Function QI&(ByVal pThis As LongPtr, _
                      ByVal riid As LongPtr, _
                      ByRef pObj As LongPtr)
     'Msg nay khong duoc goi
     QI = E_NOINTERFACE
End Function
Private Function AR&(ByVal pThis As LongPtr)
     'Trong truong hop can thiet phai goi
End Function
#If Win64 Then
Private Function DragEnter&(This As TDragDrop, _
                             ByVal pDataObj As LongPtr, _
                             ByVal grfKeyState As Long, _
                             ByVal pt As LongPtr, _
                             ByRef pdwEffect As Long)
#Else
Private Function DragEnter&(This As TDragDrop, _
                             ByVal pDataObj As LongPtr, _
                             ByVal dummy As Variant)
#End If
     Dim acc As IAccessible
     With This
         Set acc = .ctl
         acc.accLocation .rt(0), .rt(1), .rt(2), .rt(3)
         .rt(2) = .rt(2) + .rt(0)
         .rt(3) = .rt(3) + .rt(1)
     End With
End Function
#If Win64 Then
Private Function DragOver&(This As TDragDrop, _
                            ByVal grfKeyState As Long, _
                            ByVal pt As LongPtr, _
                            ByRef pdwEffect As Long)
     If PtInRect(VarPtr(This.rt(0)), pt) = 0 Then
         DragOver = E_NOTIMPL
     End If
End Function
#Else
Private Function DragOver&(This As TDragDrop, _
                            ByVal grfKeyState As Long, _
                            ByVal ptX As Long, _
                            ByVal ptY As Long, _
                            ByRef pdwEffect As Long)
     If PtInRect(VarPtr(This.rt(0)), ptX, ptY) = 0 Then
         DragOver = E_NOTIMPL
     End If
End Function
#End If
Private Function DragLeave&(ByVal pThis As LongPtr)
     DragLeave = E_NOTIMPL
End Function
#If Win64 Then
Private Function Drop&(This As TDragDrop, _
                        ByVal pDataObj As LongPtr, _
                        ByVal grfKeyState As Long, _
                        ByVal pt As LongPtr, _
                        ByRef pdwEffect As Long)
#Else
Private Function Drop&(This As TDragDrop, _
                        ByVal pDataObj As LongPtr, _
                        ByVal grfKeyState As Long, _
                        ByVal ptX As Long, _
                        ByVal ptY As Long, _
                        ByRef pdwEffect As Long)
#End If
     Dim pidl As LongPtr, buf$, hr&
     hr = SHGetIDListFromObject(pDataObj, pidl)
     If hr < 0 Then
         buf = "$(error)"
     Else
         buf = String$(256, 0)
         If SHGetPathFromIDListW(pidl, StrPtr(buf)) Then
             buf = VBA.Left$(buf, VBA.InStr(buf, vbNullChar))
         Else
             buf = vbNullString
         End If
     End If
     This.ctl.Text = buf
End Function
Cách sử dụng: Trên UserForm, bạn tạo ô Textbox1. Sau đó dán code sau vào UserForm:
Mã:
 Private mm As TDragDrop
Private Sub UserForm_Initialize()
     InitDragDrop mm, TextBox1
End Sub
Private Sub UserForm_Terminate()
     TerminateDragDrop mm
End Sub
-------------------------------------------
File Demo: để tải về
-------------------------------------------

Nguồn tham khảo:
 
Sửa lần cuối bởi điều hành viên:

tuhocvba

Administrator
Thành viên BQT
1. Không chỉ textbox, các bạn có thể thực thi kéo thả với image.
File demo
:
Bạn cần đăng nhập để thấy đa phương tiện

2. Nếu UserForm có hai ô Textbox thì sửa code như thế nào? (Vấn đề đang chờ giải quyết)
Bạn cần đăng nhập để thấy đính kèm
 

giaiphapvba

Administrator
Thành viên BQT
Nếu code trên UserForm sửa lại như sau:
Mã:
Private mm As TDragDrop

Private Sub TextBox1_Change()
    InitDragDrop mm, TextBox2
End Sub
Private Sub TextBox2_Change()
    InitDragDrop mm, TextBox1
End Sub
Private Sub UserForm_Initialize()
     InitDragDrop mm, TextBox1
End Sub

Private Sub UserForm_Terminate()
     TerminateDragDrop mm
End Sub
Khi thả vào Textbox1 => có thể thực hiện thả vào Textbox2.
Khi thả vào Textbox2 => có thể thực hiện thả vào Textbox1.


Nhưng:
Khi thả vào Textbox1 => Muốn thực hiện thao tác thả vào Textbox1 một lần nữa ngay sau đó, thì không còn được nữa.
 

NhanSu

Thành Viên Nổi Bật

Mặc dù code này mình không hiểu nhưng để sử dụng 2 textbox thì ta nhét 1 textbox trong frame rồi sửa code trong form thành:
Mã:
 Private mm As TDragDrop
 Private mm2 As TDragDrop
 Private Sub UserForm_Initialize()
     InitDragDrop mm, TextBox1
     InitDragDrop mm2, TextBox2
 End Sub
 Private Sub UserForm_Terminate()
     TerminateDragDrop mm
     TerminateDragDrop mm2
 End Sub
 

tuhocvba

Administrator
Thành viên BQT
Mình vừa thử thành công. Đúng như kỳ vọng rồi. Đúng như kỳ vọng, quả nhiên @NhanSu đã giải quyết được. Giỏi. Cảm ơn bạn rất nhiều.
 

NhanSu

Thành Viên Nổi Bật

Trong code InitDragDrop có dòng
Mã:
Set buf=ctl
Set buf = buf.Parent
Vì ctl là textbox nên buf sẽ được gán cho đối tượng chứa textbox đó. Khi có 2 textbox trên form không làm được nên mình đoán cần phải thay đổi parent của ít nhất 1 trong 2 textbox, mà parent của control trong frame chính là frame nên mình thử đại, may lại được.
 

tuhocvba

Administrator
Thành viên BQT
Vì ctl là textbox nên buf sẽ được gán cho đối tượng chứa textbox đó. Khi có 2 textbox trên form không làm được nên mình đoán cần phải thay đổi parent của ít nhất 1 trong 2 textbox, mà parent của control trong frame chính là frame nên mình thử đại, may lại được.
Bạn giỏi lắm, rất đúng ý mình. Mình vừa thử với 3 ô textbox cũng vẫn được.
 

Euler

Mod
Thành viên BQT
Dựa vào đề xuất sử dụng Frame ở , tôi hệ thống lại hướng dẫn như sau:
Trên UserForm, bạn sử dụng các Frame để chứa ô Textbox. Ví dụ:
Bạn cần đăng nhập để thấy đính kèm

Để các Frame không hiển thị gây vướng mắt, ta thiết định các thuộc tính cho nó như sau:
  • Caption là rỗng .
  • SpecialEffect = 0-fmSpecialEffectFlat

Kết quả:
Bạn cần đăng nhập để thấy đính kèm


Code trên UserForm giống như bạn NhanSu đã đề xuất:
Mã:
 Private mm As TDragDrop
 Private mm2 As TDragDrop


 Private Sub UserForm_Initialize()
     InitDragDrop mm, TextBox1
     InitDragDrop mm2, TextBox2
 End Sub

 Private Sub UserForm_Terminate()
     TerminateDragDrop mm
     TerminateDragDrop mm2
 End Sub
File demo:
 
Top