Drag And Drop File VBA

[cgmojoco]

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-

 

[tph216]

Just for completeness and for anyone else looking to do this, I amended the first subroutine to:

Private Sub FileHyperLink_AfterUpdate()
Dim hlink As Hyperlink

Me.FileHyperLink.Value = RelativeToAbsoluteHyperlink(Me.FileHyperLink.Value)

Set hlink = Me.FileHyperLink.Hyperlink

Me.FilePath.Value = CurrentProject.Path & "\" & hlink.Address
Me.FileHyperLink.Value = vbNullString

DoCmd.RunCommand acCmdSaveRecord

End Sub

Which then delivers the full path as a string to the FilePath field. Although, that won't work for anything above the database directory in the folder hierarchy. Hmm...

I can probably work with that, but it makes me a little uneasy. :/

 

[tph216]

Ok, further to that, I've gone into File>Manage>Database Properties>Summary, and changed the "Hyperlink Base" field to a space (" ").

This seems to force an absolute path to be generated.

You could also put C:\ in there (or whatever), to force the path to be generated from where ever you want, I guess.

 

[Kreszch68]

I debugged the functions to retrieve the full path. Now you can grab files from anywhere.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
As I’m working on a project where I could use the drag n drop functionality as well, I came up with the following solution to enable drag en dropping files on a form.<o></o>
I’ve created a table with just one field ‘DropZone’ (DataType = Hyperlink) and called the table ‘DropZone’, in this table I made one blank entry (I’ll clarify this if you read on).<o></o>
Then I made a form also called DropZone, based on the table DropZone and put the DropZone control on it, dimensions 6x3 cm, background style = transparent. Behind this control I placed a label with the same dimensions, here you can put your text like “Drag files to here”. <o></o>
One more textbox control on the form, called DummyControl, place this control left from de DropZone control, dimensions 0,002cm (don’t make invisible).<o></o>
Set the form dimensions equal to the DropZone control, AllowAdditions = false (this is why you need 1 entry to the table DropZone). Disable record selectors, navigation etc. to end up with a form only displaying the DropZone control.<o></o>
Put the next code into the form code.<o></o>

Option Compare Database
Private Sub Form_Load()
    Me.DummyControl.SetFocus
End Sub
Private Sub DropZone_Click()
    Me.DummyControl.SetFocus
End Sub
Private Sub DropZone_AfterUpdate()
Dim hLink As Hyperlink
Me.DropZone.Value = RelativeToAbsoluteHyperlink(Me.DropZone.Value)
Set hLink = Me.DropZone.Hyperlink
    Me.Parent!sFilePath.Value = hLink.Address
    Me.DropZone.Value = vbNullString
    Me.DummyControl.SetFocus
End Sub
Public Function ExtractDirName(ByVal sPathName As String, _
                               Optional ByVal sDelimiter As String = "\") As String
  Dim iIndex As Integer
 
  For iIndex = VBA.Len(sPathName) To 1 Step -1
    If Mid(sPathName, iIndex, 1) = sDelimiter Then Exit For
  Next iIndex
  If iIndex <= 1 Then
    ExtractDirName = ""
  Else
    ExtractDirName = VBA.Left(sPathName, iIndex - 1)
  End If
End Function
Public Function ExtractFileName(ByVal sPathName As String, _
                                Optional ByVal sDelimiter As String = "\") As String
  Dim iIndex As Integer
  For iIndex = VBA.Len(sPathName) To 1 Step -1
        If Mid(sPathName, iIndex, 1) = sDelimiter Then Exit For
  Next iIndex
  ExtractFileName = VBA.Right(sPathName, VBA.Len(sPathName) - iIndex)
End Function
Public Function RelativeToAbsoluteHyperlink(ByVal sHyperlink As String) As String
  Dim sTemp() As String
  Dim iIndex As Integer
  Dim sResult As String
  If Nz(sHyperlink, "") <> "" Then
    sTemp() = Split(sHyperlink, "#", , vbTextCompare)
    For iIndex = LBound(sTemp) To UBound(sTemp)
           If Len(sTemp(iIndex)) > 0 Then
                      If Left(sTemp(iIndex), 2) = ".." Then
                        sTemp(iIndex) = Replace(sTemp(iIndex), "/", "\")
                      End If
               sTemp(iIndex) = RelativeToAbsolutePath(sTemp(iIndex))
 
            End If
            If iIndex = LBound(sTemp) Then
                sResult = sTemp(iIndex)
            Else
                sResult = sResult & "#" & sTemp(iIndex)
            End If
    Next iIndex
  End If
 
  RelativeToAbsoluteHyperlink = sResult
End Function
Function RelativeToAbsolutePath(ByVal sRelativePath As String, _
                                Optional ByVal sStartPath As String = "", _
                                Optional ByVal sDelimiter As String = "\") As String
 
  Dim iCount As Integer
  Dim iIndex As Integer
  Dim iIndex2 As Integer
 
  Dim sFileName As String
  Dim sPathName As String
  Dim sResult As String
  Dim sSplit() As String
  Dim sSplit2() As String
  Dim sTemp As String
  Dim bIsCurrent As Boolean
 
  If sStartPath = "" Then
    sStartPath = Application.CurrentProject.Path
    bIsCurrent = True
  End If
  If (Left(sRelativePath, 2) = "\\") Or _
    (Mid(sRelativePath, 2, 1) = ":") Or _
    (Left(sRelativePath, 5) = "http:") Or _
    (Left(sRelativePath, 6) = "https:") Or _
    (Left(sRelativePath, 4) = "ftp:") Or _
    (Left(sRelativePath, 7) = "mailto:") Or _
    (Left(sRelativePath, 7) = "callto:") Then
    'Path is already absolute
    RelativeToAbsolutePath = sRelativePath
    Exit Function
  End If
 
  sPathName = ExtractDirName(sRelativePath, sDelimiter)
  sFileName = ExtractFileName(sRelativePath, sDelimiter)
  If Left(sPathName, 2) = ".." Then
    'Go up
    iCount = 0
    sSplit() = Split(sPathName, sDelimiter, -1, vbTextCompare)
    sSplit2() = Split(sStartPath, sDelimiter, -1, vbTextCompare)
    For iIndex = 0 To UBound(sSplit())
      If sSplit(iIndex) = ".." Then
        iCount = iCount + 1
        sResult = ""
                For iIndex2 = 0 To UBound(sSplit2()) - iCount
                        If sResult <> "" Then
                          sResult = sResult & sDelimiter
                        End If
                  sResult = sResult & sSplit2(iIndex2)
                Next iIndex2
      Else
                If sResult <> "" Then
                  sResult = sResult & sDelimiter
                End If
        sResult = sResult & sSplit(iIndex)
      End If
    Next iIndex
    sResult = sResult & sDelimiter & sFileName
  Else
    sResult = sRelativePath
  End If
 
  If bIsCurrent = True Then
    RelativeToAbsolutePath = sStartPath & sDelimiter & sResult
  Else
    RelativeToAbsolutePath = sResult
  End If
 
End Function

Now you can place this form on any form as a subform. You only need to create a control on the parent form named sFilePath. If you drag a file to the DropZone the full path will be displayed in the sFileName control on the parent form.<o></o>

 

[Kreszch68]

Ok, forget my previous post.
I have sorted it out for once and for all now.
For those who want to know how, I have uploaded a working example database (Access 2007) to my livedrive portal.

Check it out!

http://karjo.livedrive.com/item/bc65801febb642b99d0cbf99bd33a789

Any feedback would be appriciated of course.

 

[cgmojoco]

Very cool.
I'm getting an error on this line from the code in the form on your URL

Me.Parent!sFilePath.Value = sHlinkAddress:

Run-time error '2452':
The expression you entered has an invalid referent to the Parent property.

Other than that it works fine. It adds the link and calls up the directory.
I tried adding on error resume next a line above to see if it would fix...it stopped working at that point. Weird.

 

[Kreszch68]

Okay, maybe I should have given some more information on how to use this.

In the database you'll find a form, called frmUseDropZone.

This is the form to use, otherwise, if you use the form DropZone directly, it's missing the parent form (which is frmUseDropZone).

Hope this will do the trick.