Home

Drag and Drop a file within a form in Microsoft Access 2016 on Windows 10 problem

ktesler
New Contributor

I have an Access Database that was designed and working fine in Windows 7 with Access 2010.  It has a form that allows you to drag a file from the desktop (such as a pdf file) and load the path on the form for further action in order to transport the file over to a folder on a share drive.  In Windows 10 and Access 2016, it no longer works.  Has something changed with an API reference?  I am attaching the code below.  I appreciate your input and suggestions on this.

 

Thanks.

 

KT

 

Option Compare Database
Option Explicit

'basDragDrop
'2011-09 jl

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

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

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

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

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

Private 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

Const GWL_WNDPROC As Long = -4
Const GWL_EXSTYLE = -20

Const WM_DROPFILES = &H233

Const WS_EX_ACCEPTFILES = &H10

Private currFrm As Access.Form 'reference to the Form currently
                               'hooked to the callback.  This
                               'is required to pass the dropped
                               'files to the form
Private currHwndFrm As Long 'handle to the currently hooked form
                            'this is used to verify there isn't
                            'two forms hooked at the same time
                            '(for example overlapping controls
                            'where the mouse jumps from one
                            'to the other)
Private prevWndProc As Long 'handle to the window's previous
                            'WindowProc.  This is only set while
                            'currHwndFrm is valid

Private hookOn As Boolean


Public Function DragDropInitForm(hWndFrm As Long)
  'inits the form for drag/drop
  Dim lExStyle As Long
 
  'get the current extended window style
  lExStyle = GetWindowLong(hWndFrm, GWL_EXSTYLE)
  'add the flag for accepting dragged files
  lExStyle = lExStyle Or WS_EX_ACCEPTFILES
  'set the new extended window style
  SetWindowLong hWndFrm, GWL_EXSTYLE, lExStyle
 
  'register the form for drag/drop acceptance
  DragAcceptFiles hWndFrm, True
 
End Function


Public Function DragDropSetHook(hookOn As Boolean, hWndFrm As Long)
  'toggles the hook on or off
  If hookOn Then
    dragDropHookOn hWndFrm
    'Debug.Print "HookOn"
  Else
    dragDropHookOff
    'Debug.Print "HookOff"
  End If
End Function

Public Function DragDropCallback( _
  ByVal hWnd As Long, _
  ByVal msg As Long, _
  ByVal wparam As Long, _
  ByVal lparam As Long _
  ) As Long
  'callback for drag/drops
 
  'as in all callbacks, we're screwed if there's an error
  'and need to be absolutely certain this procedure will
  'exit
  On Error Resume Next

  'We want to turn this hook off as soon as possible after
  'the files are dropped, otherwise it clogs up the rest
  'of the project operations.  It just so happens that the
  'MouseMove event for a control accepting the dropped files
  'fires exactly one time when the files are physically
  'dropped on the form - that one time is where this hook
  'is turned on, so it's almost a safe bet that we can
  'turn this directly back off as soon as it's called.
  '
  'If you experience occasional times where you drop files
  'but they do not register, set the DDH_MAXCALLS constant
  'to a higher number.  In Access 2010 in particular this
  'number seems to want to be set around 50 or so for
  'it to work every time.  You might need to go higher

 
  Const DDH_MAXCALLS = 150
  Static intCallCount As Integer
 
  If msg <> WM_DROPFILES Then
    'the hWnd parameter passed to this function by the OS is
    'the handle to the form that was hooked.  If the message
    'is not for a file drop, we'll send the message to that
    'form's standard message procedure
    CallWindowProc ByVal prevWndProc, _
                   ByVal hWnd, _
                   ByVal msg, _
                   ByVal wparam, _
                   ByVal lparam
  Else
    'we have a file drop, handle that
    dragDropQueryFiles wparam
  End If
 
  'check the callcount and unhook if required
  intCallCount = intCallCount + 1
  If intCallCount >= DDH_MAXCALLS Then
    intCallCount = 0
    DragDropSetHook False, hWnd
  End If
 
End Function


Private Sub dragDropQueryFiles(hDrop As Long)
  'passes a semicolon delimited list of the dropped
  'files to the currFrm.DragDropFiles() sub
 
  Const MAX_PATH = 255
  Dim ret As String 'function return
  Dim s As String 'temp/various
  Dim Icount As Integer 'count of files dropped
  Dim iPathLen As Integer 'length of the current path
  Dim I As Integer 'temp/various
 
  'get the count of files dropped
  s = String(MAX_PATH, 0)
  Icount = DragQueryFile(hDrop, &HFFFFFFFF, s, Len(s))
 
  'iterate the filecount and build the return
  For I = 0 To Icount - 1
    s = String(MAX_PATH, 0)
    iPathLen = DragQueryFile(hDrop, I, s, MAX_PATH)
    ret = ret & ";" & Left(s, iPathLen)
  Next I
   
  DragFinish hDrop
 
  currFrm.DragDropFiles Mid(ret, 2)
   
End Sub


Private Function dragDropHookOn(hWndFrm As Long)
  'turns the callback on
  If hookOn Then Exit Function
  'set the current form and handle for later use
  currHwndFrm = hWndFrm
  Set currFrm = dragDropGetFrmFromHWnd(hWndFrm)
  'use SetWindowLong to set the new callback address
  'and return the previous callback address to prevWndProc
  prevWndProc = SetWindowLong(hWndFrm, GWL_WNDPROC, AddressOf DragDropCallback)
  hookOn = True
End Function

Private Function dragDropHookOff()
  'turns the callback off
 
  'set the window's callback address to it's previous value
  SetWindowLong currHwndFrm, GWL_WNDPROC, prevWndProc
  'clear the window and callback settings until next callback init
  prevWndProc = 0
  currHwndFrm = 0
  Set currFrm = Nothing
  hookOn = False
End Function


Private Function dragDropGetFrmFromHWnd(hWnd As Long) As Access.Form
  'retrieves a form reference from the form's handle
  'this reference is later used to call the form's procedure and pass
  'it the dropped file list
  Dim frm As Access.Form
  For Each frm In Access.Forms
    If frm.hWnd = hWnd Then Exit For
  Next frm
  Set dragDropGetFrmFromHWnd = frm
End Function

1 Reply

UPDATE...

 

So I am able to drag and drop a file and this is what I did.  I had to click in the form a few times first and then I can drag the  file over the form and it will take it.

 

I think it may have to do with this part of the code:

 

 'If you experience occasional times where you drop files
  'but they do not register, set the DDH_MAXCALLS constant
  'to a higher number.  In Access 2010 in particular this
  'number seems to want to be set around 50 or so for
  'it to work every time.  You might need to go higher

 
  Const DDH_MAXCALLS = 150
  Static intCallCount As Integer

 

Any thoughts or ideas on how to make the form respond like it does on Windows 7?

Related Conversations
Tabs and Dark Mode
cjc2112 in Discussions on
46 Replies
Extentions Synchronization
Deleted in Discussions on
3 Replies
Stable version of Edge insider browser
HotCakeX in Discussions on
35 Replies
How to Prevent Teams from Auto-Launch
chenrylee in Microsoft Teams on
30 Replies
flashing a white screen while open new tab
Deleted in Discussions on
14 Replies
Security Community Webinars
Valon_Kolica in Security, Privacy & Compliance on
13 Replies