Drag And Drop File VBA

cgmojoco · Aug 7, 2009

Hi there-

I want to be able to drop a file into a specific are of an access form that will trigger VBA to save that file into a specific directory and rename it with data from fields in the open form.

Can anyone point me in the right direction on what control I might be able to use that will allow an Access form to recognize that a file is being dropped into it, 'take control' of the file and kick off the appropriate VBA to save the file out to where I need it stored?

Secondly, once I have this down I'd like to know how to have a link to the file auto populated in a field of that same form.

Thanks in advance-

cgmojoco · Aug 10, 2009

I guess this is a step in the right direction does anyone have any feedback?

Code:

'******** Code Start ********
Private Sub Form_Open(Cancel as Integer)
    Call sEnableDrop(Me)
    Call sHook(Me.Hwnd, "sDragDrop")
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call sUnhook(Me.Hwnd)
End Sub
'******** Code  End ********  
Paste this code in a new module.
'************* Code Start *************
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
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)
        With Forms!frmDragDrop!lstDrop
            .RowSourceType = "Value List"
            .RowSource = strOut
            Forms!frmDragDrop.Caption = "DragDrop: " & _
                                                    .ListCount & _
                                                    " files dropped."
        End With
        
    Else
        lngRet = apiCallWindowProc( _
                            ByVal lpPrevWndProc, _
                            ByVal Hwnd, _
                            ByVal Msg, _
                            ByVal wParam, _
                            ByVal lParam)
    End If
End Sub

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


Sub sHook(Hwnd As Long, _
                strFunction As String)
    lpPrevWndProc = apiSetWindowLong(Hwnd, _
                                            GWL_WNDPROC, _
                                            AddrOf(strFunction))
End Sub

Sub sUnhook(Hwnd As Long)
Dim lngTmp As Long
    lngTmp = apiSetWindowLong(Hwnd, _
                    GWL_WNDPROC, _
                    lpPrevWndProc)
    lpPrevWndProc = 0
End Sub
'**************** Code End ***************
'Access greater than 2000?  Use below
'Else use [FONT=Verdana, Arial][SIZE=2]Dev's code refers to a class module named "AddrOf" that is available
here: [URL]http://www.trigeminal.com/lang/1033/codes.asp?ItemID=19#19[/URL]
However, this module has errors under Access 2003 when it runs, one of
which says a DLL file is missing.[/SIZE][/FONT]
Sub sHook(Hwnd As Long, _
                strFunction As String)
    'lpPrevWndProc = apiSetWindowLong(Hwnd, GWL_WNDPROC,
AddrOf(strFunction))
    Select Case strFunction
        Case "sDragDrop"
            lpPrevWndProc = apiSetWindowLong(Hwnd, GWL_WNDPROC,
AddressOf sDragDrop)
        Case Else
            Debug.Assert False  'Need to setup this function as
another Case.
    End Select
End Sub

cgmojoco · Aug 10, 2009

I was able to get that to recognize that I was dragging and dropping a file...it showed me the link to the file.

But it locks up inadvertently so I am back to sqaure one, anyone know how to let Access recognize that I am dropping a file into it?

cgmojoco · Aug 28, 2009

Bump, any ideas?

I would really like to be able to drag and drop a file into a part of my form and have code that would save the file out to network drive...

redbaron06 · Aug 5, 2011

Sorry for bumping an old topic, but I have also been looking to do the same procedure. Thanks in advance for any ideas!

tph216 · Jan 4, 2012

Hello,

I am also looking to do exactly this.

I am trying to build a document management system which is lightweight and intuitive to use. I want to file technical references for engineers into one folder, identified by a sequential number / primary key. I then want to use Access to store meta-data about each file, in a similar way to how MP3's are tagged with data.

I want to remove the burden of thinking about filing from the engineer. So they just drop a file onto a control on a form, type in the relevant meta-data, and then hit ok. Done. All filed away and easily searchable / retrievable via various queries elsewhere.

I think to do this, the only bit I am really missing is how to "get" the relevant hyperlink when a file is 'dropped' onto some sort of control. Once I have this hyperlink, I think I can program routines to:

1. Copy the file in question to the new location (the references folder).
2. Change the filename to be a concatenation of the primary key from access, plus a short descriptive "name" of some sort.
3. Delete the old file that was originally dropped.

I intend to have hundreds or potentially even thousands of files in the references folder, and use as-you-type searching in Access (which I've successfully implemented before) to allow pertinent references to be identified and retrieved within a matter of seconds. This is currently done often and takes many minutes to track down the relevant references, so it'd be a huge time saver.

Kreszch68 · Jan 5, 2012

Hi all,

if the purpose is just to get a full path of a file that's dragged onto the form, your salvation is near

.
In Access you can create a table with a field set to Hyperlink. When you place this field on a form, you will be able to drag any file from the Windows Explorer into this field.

But of course there is always a but. Normally you'd expect to simply retrieve the hyperlink address from the hyperlink field. Somehow you'll end up with a relative path, or even worse an absolute path starting with the default path set under you're database options.

Now I will explain how to deal with this. For this example create a simple table with just two fields, FileHyperlink (type = hyperlink) and FilePath(type = text). Then create a form and place the two fields on the form.

Copy this code to the form code

Code:

Option Compare Database

Private Sub FileHyperLink_AfterUpdate()
Dim hlink As Hyperlink
Me.FileHyperLink.Value = RelativeToAbsoluteHyperlink(Me.FileHyperLink.Value)
Set hlink = Me.FileHyperLink.Hyperlink
Me.FilePath.Value = hlink.Address
Me.FileHyperLink.Value = vbNullString
DoCmd.RunCommand acCmdSaveRecord
End Sub
Function ExtractDirName(strPathName As String, Optional strDelimiter As String = "\") As String
  Dim intIndex As Integer
  For intIndex = VBA.Len(strPathName) To 1 Step -1
    If Mid(strPathName, intIndex, 1) = strDelimiter Then Exit For
  Next
  If intIndex <= 1 Then
    ExtractDirName = ""
  Else
    ExtractDirName = VBA.Left(strPathName, intIndex - 1)
  End If
End Function
Function ExtractFileName(strPathName As String, Optional strDelimiter As String = "\") As String
  Dim intIndex As Integer
  For intIndex = VBA.Len(strPathName) To 1 Step -1
    If Mid(strPathName, intIndex, 1) = strDelimiter Then Exit For
  Next
  ExtractFileName = VBA.Right(strPathName, VBA.Len(strPathName) - intIndex)
End Function
Function RelativeToAbsoluteHyperlink(strHyperlink As String) As String
  Dim strTemp() As String
  Dim intIndex As Integer
  Dim strResult As String
  If Nz(strHyperlink, "") <> "" Then
    strTemp() = Split(strHyperlink, "#", , vbTextCompare)
    For intIndex = LBound(strTemp) To UBound(strTemp)
      If Len(strTemp(intIndex)) > 0 Then
        If Left(strTemp(intIndex), 2) = ".." Then
          strTemp(intIndex) = Replace(strTemp(intIndex), "/", "\")
        End If
        strTemp(intIndex) = RelativeToAbsolutePath(strTemp(intIndex))
      '  Debug.Print strTemp(intIndex)
      End If
      If intIndex = LBound(strTemp) Then
        strResult = strTemp(intIndex)
      Else
        strResult = strResult & "#" & strTemp(intIndex)
      End If
    Next
  End If
  RelativeToAbsoluteHyperlink = strResult
End Function
Function RelativeToAbsolutePath(strRelativePath As String, _
  Optional strStartPath As String = "", _
  Optional strDelimiter As String = "\") As String
  
  Dim intCount As Integer
  Dim intIndex As Integer
  Dim intIndex2 As Integer
  
  Dim strFileName As String
  Dim strPathName As String
  Dim strResult As String
  Dim strSplit() As String
  Dim strSplit2() As String
  Dim strTemp As String
  
  If strStartPath = "" Then
    strStartPath = Application.CurrentProject.Path
  End If
  If (Left(strRelativePath, 2) = "\\") Or _
    (Mid(strRelativePath, 2, 1) = ":") Or _
    (Left(strRelativePath, 5) = "http:") Or _
    (Left(strRelativePath, 6) = "https:") Or _
    (Left(strRelativePath, 4) = "ftp:") Or _
    (Left(strRelativePath, 7) = "mailto:") Or _
    (Left(strRelativePath, 7) = "callto:") Then
    'Path is already absolute
    RelativeToAbsolutePath = strRelativePath
    Exit Function
  End If
  
  strPathName = ExtractDirName(strRelativePath, strDelimiter)
  strFileName = ExtractFileName(strRelativePath, strDelimiter)
  If Left(strPathName, 2) = ".." Then
    'Go up
    intCount = 0
    strSplit() = Split(strPathName, strDelimiter, -1, vbTextCompare)
    strSplit2() = Split(strStartPath, strDelimiter, -1, vbTextCompare)
    For intIndex = 0 To UBound(strSplit())
      If strSplit(intIndex) = ".." Then
        intCount = intCount + 1
        strResult = ""
        For intIndex2 = 0 To UBound(strSplit2()) - intCount
          If strResult <> "" Then
            strResult = strResult & strDelimiter
          End If
          strResult = strResult & strSplit2(intIndex2)
        Next
      Else
        If strResult <> "" Then
          strResult = strResult & strDelimiter
        End If
        strResult = strResult & strSplit(intIndex)
      End If
    Next
    strResult = strResult & strDelimiter & strFileName
  Else
    strResult = strRelativePath
  End If
  
  RelativeToAbsolutePath = strResult
End Function

Now start the form and drag a file to the FileHyperlink control. Voila, you'll have the full path in the FilePath field.
From here you can build you're app.

tph216 · Jan 5, 2012

Kreszch68 said:

Hi all,

if the purpose is just to get a full path of a file that's dragged onto the form, your salvation is near

.
In Access you can create a table with a field set to Hyperlink. When you place this field on a form, you will be able to drag any file from the Windows Explorer into this field.

But of course there is always a but. Normally you'd expect to simply retrieve the hyperlink address from the hyperlink field. Somehow you'll end up with a relative path, or even worse an absolute path starting with the default path set under you're database options.

Now I will explain how to deal with this. For this example create a simple table with just two fields, FileHyperlink (type = hyperlink) and FilePath(type = text). Then create a form and place the two fields on the form.

Copy this code to the form code

Code:

Option Compare Database

Private Sub FileHyperLink_AfterUpdate()
Dim hlink As Hyperlink
Me.FileHyperLink.Value = RelativeToAbsoluteHyperlink(Me.FileHyperLink.Value)
Set hlink = Me.FileHyperLink.Hyperlink
Me.FilePath.Value = hlink.Address
Me.FileHyperLink.Value = vbNullString
DoCmd.RunCommand acCmdSaveRecord
End Sub
Function ExtractDirName(strPathName As String, Optional strDelimiter As String = "\") As String
  Dim intIndex As Integer
  For intIndex = VBA.Len(strPathName) To 1 Step -1
    If Mid(strPathName, intIndex, 1) = strDelimiter Then Exit For
  Next
  If intIndex <= 1 Then
    ExtractDirName = ""
  Else
    ExtractDirName = VBA.Left(strPathName, intIndex - 1)
  End If
End Function
Function ExtractFileName(strPathName As String, Optional strDelimiter As String = "\") As String
  Dim intIndex As Integer
  For intIndex = VBA.Len(strPathName) To 1 Step -1
    If Mid(strPathName, intIndex, 1) = strDelimiter Then Exit For
  Next
  ExtractFileName = VBA.Right(strPathName, VBA.Len(strPathName) - intIndex)
End Function
Function RelativeToAbsoluteHyperlink(strHyperlink As String) As String
  Dim strTemp() As String
  Dim intIndex As Integer
  Dim strResult As String
  If Nz(strHyperlink, "") <> "" Then
    strTemp() = Split(strHyperlink, "#", , vbTextCompare)
    For intIndex = LBound(strTemp) To UBound(strTemp)
      If Len(strTemp(intIndex)) > 0 Then
        If Left(strTemp(intIndex), 2) = ".." Then
          strTemp(intIndex) = Replace(strTemp(intIndex), "/", "\")
        End If
        strTemp(intIndex) = RelativeToAbsolutePath(strTemp(intIndex))
      '  Debug.Print strTemp(intIndex)
      End If
      If intIndex = LBound(strTemp) Then
        strResult = strTemp(intIndex)
      Else
        strResult = strResult & "#" & strTemp(intIndex)
      End If
    Next
  End If
  RelativeToAbsoluteHyperlink = strResult
End Function
Function RelativeToAbsolutePath(strRelativePath As String, _
  Optional strStartPath As String = "", _
  Optional strDelimiter As String = "\") As String
  
  Dim intCount As Integer
  Dim intIndex As Integer
  Dim intIndex2 As Integer
  
  Dim strFileName As String
  Dim strPathName As String
  Dim strResult As String
  Dim strSplit() As String
  Dim strSplit2() As String
  Dim strTemp As String
  
  If strStartPath = "" Then
    strStartPath = Application.CurrentProject.Path
  End If
  If (Left(strRelativePath, 2) = "\\") Or _
    (Mid(strRelativePath, 2, 1) = ":") Or _
    (Left(strRelativePath, 5) = "http:") Or _
    (Left(strRelativePath, 6) = "https:") Or _
    (Left(strRelativePath, 4) = "ftp:") Or _
    (Left(strRelativePath, 7) = "mailto:") Or _
    (Left(strRelativePath, 7) = "callto:") Then
    'Path is already absolute
    RelativeToAbsolutePath = strRelativePath
    Exit Function
  End If
  
  strPathName = ExtractDirName(strRelativePath, strDelimiter)
  strFileName = ExtractFileName(strRelativePath, strDelimiter)
  If Left(strPathName, 2) = ".." Then
    'Go up
    intCount = 0
    strSplit() = Split(strPathName, strDelimiter, -1, vbTextCompare)
    strSplit2() = Split(strStartPath, strDelimiter, -1, vbTextCompare)
    For intIndex = 0 To UBound(strSplit())
      If strSplit(intIndex) = ".." Then
        intCount = intCount + 1
        strResult = ""
        For intIndex2 = 0 To UBound(strSplit2()) - intCount
          If strResult <> "" Then
            strResult = strResult & strDelimiter
          End If
          strResult = strResult & strSplit2(intIndex2)
        Next
      Else
        If strResult <> "" Then
          strResult = strResult & strDelimiter
        End If
        strResult = strResult & strSplit(intIndex)
      End If
    Next
    strResult = strResult & strDelimiter & strFileName
  Else
    strResult = strRelativePath
  End If
  
  RelativeToAbsolutePath = strResult
End Function

Now start the form and drag a file to the FileHyperlink control. Voila, you'll have the full path in the FilePath field.
From here you can build you're app.

Hi Kreszch68, thanks for this reply.

This is great, I didn't realise you could already drag & drop onto a hyperlink field.

However, the path is indeed coming out a bit weirdly as you mentioned, and the code you posted hasn't fixed it on my machine. Are there any particular references you are running that might affect it?

What's happening is that when I drop the file onto the hyperlink field, it is displaying a proper link underlined in blue, e.g. readme.txt.

Then the afterupdate routine appears to copy this as a string into the filepath field, so it ends up with the string "readme.txt" as the value in the filepath field (as opposed to a string of the absolute filepath, as desired).

I'm having a play to sort it out myself, but thought I'd post to let you know that I'm halfway there now (thanks), and on the off-chance that you might have a quick fix to the correction issue I'm now looking at.

Kreszch68 · Jan 5, 2012

Hi,

well there is one little bug in the code.
If you're file is in the same folder as your databasefile it only returns the filename. Probably this is the case.

Try to put the test file in an other folder and it should work fine.

regards,

Johan

tph216 · Jan 5, 2012

Ah this could be it, they are in the same folder. And playing about with debugging, it looks as though the following were being 'stored' in the field value:

Me.FileHyperLink.Hyperlink.Address = "Readme.txt"
Me.FileHyperLink.Hyperlink.Screentip = ""
Me.FileHyperLink.Hyperlink.TextToDisplay = "Readme.txt"

Must be some sort of "helpful" shortcut incorporated by MS that isn't actually that helpful!?

Ah ok, tried it now. I get what its doing. Think I can sort it now. Thanks.

Drag And Drop File VBA

cgmojoco

Well-known Member

Excel Facts

cgmojoco

Well-known Member

cgmojoco

Well-known Member

cgmojoco

Well-known Member

redbaron06

New Member

tph216

New Member

Kreszch68

Active Member

tph216

New Member

Kreszch68

Active Member

tph216

New Member

Similar threads

Forum statistics

Share this page

Drag And Drop File VBA

Well-known Member

Excel Facts

Well-known Member

Well-known Member

Well-known Member

New Member

New Member

Active Member

New Member

Active Member

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock