download hyperlinks to a folder (1 Viewer)

[laffeg]

hi
I have a query showing a subset of records including a hyperlink field
I need a form button to run a do while not EOF loop to save each file to a folder

never done anything like this before so no idea what would be the best method.
Found URLDownloadtoFile but struggling to see the correct syntax and declarations needed

was hoping it would be as simple as URLDownloadToFile 0, link.value, path, 0, 0

where link is the name of the field

can anyone point me in right direction?
thanks

 

[Ranman256]

paste the code into a module,
usage: CopyFiles2Dir [sourceFolder], [TargetFolder]

Public Sub CopyFiles2Dir(ByVal pvSrcDir, ByVal pvTargDir)
Dim fs As Object
Dim Folder As Object
Dim oFile As Object
Dim vName, vTargFile
    
pvTargDir = FixDir(pvTargDir) 'make sure it has slash

Set fs = CreateObject("Scripting.filesystemObject")
Set Folder = fs.GetFolder(pvSrcDir)

For Each oFile In Folder.Files
    
   'If InStr(oFile.Name, ".xls") > 0 Then    'or put your file type here
       vName = oFile.Name
       vTargFile = pvTargDir & vName
       
         'copy file
       Copy1File oFile, vTargFile
         
          'move the file
       'Name oFile As vTargFile
    'End If
    
skip1:
Next

Set oFile = Nothing
Set Folder = Nothing
Set fs = Nothing
End Sub


Public Function Copy1File(ByVal pvSrc, ByVal pvTarg) As Boolean
Dim fso
On Error GoTo errMake

Set fso = CreateObject("Scripting.FileSystemObject")    '(reference: ms Scripting Runtime)
fso.CopyFile pvSrc, pvTarg
Copy1File = True
Set fso = Nothing
Exit Function

errMake:
'MsgBox Err.Description & vbCrLf & pvSrc, , "Copy1File(): " & Err
Set fso = Nothing
End Function



'check dir path has a backslash at the end for attaching more files or dirs to it
Public Function FixDir(pvPath)
If pvPath = "" Then Exit Function
If Right(pvPath, 1) <> "\" Then pvPath = pvPath & "\"
FixDir = pvPath
End Function

 

[laffeg]

thanks Ranman256

I tried calling Copy1File first - when the first file appeared I thought great - however it then proceeded to just overwrite/rename that 1 file as it looped thru records

Private Sub refreshbp_Click()
Dim dbs As DAO.Database
    Dim rsQuery As DAO.Recordset
      Set dbs = CurrentDb
  
    'Open a dynaset-type Recordset using a saved query
    Set rsQuery = dbs.OpenRecordset("qrybrunning", dbOpenDynaset)
    With rsQuery
    Do While Not .EOF
    Call CopyFiles2Dir(rsQuery!link.Value, "S:\ProdSpecs\Active\")
    Loop
    End With
    rsQuery.Close
    
End Sub

link is the fieldname containing the hyperlink

 

[arnelgp]

Private Sub refreshbp_Click()
    Dim dbs As DAO.Database
    Dim rsQuery As DAO.Recordset
    Dim sPath As String, sFile As String
      Set dbs = CurrentDb

    'Open a dynaset-type Recordset using a saved query
    Set rsQuery = dbs.OpenRecordset("qrybrunning", dbOpenDynaset)
    With rsQuery
        Do While Not .EOF
            sPath = Split(!link & "", "#")(1)
            If InStr(1, sPath, "\") = 0 Then
                sPath = Environ$("userprofile") & "\documents\" & sFile
            End If
            On Error Resume Next
            sFile = Mid$(sPath, InStrRev(sPath, "\") + 1)
            Kill "S:\ProdSpecs\Active\" & sFile
            On Error GoTo 0
            FileCopy sPath, "S:\ProdSpecs\Active\" & sFile
            .MoveNext
        Loop
        .Close
    End With
    Set rsQuery = Nothing
    Set dbs = Nothing
End Sub

 

[laffeg]

hi arnelgp

that throws run-time error 9 subscript out of range error on the first Split line

i've never used Split before - does that need a reference adding ?

 

[arnelgp]

then maybe your field is not Hyperlink field?
do you have blanks in !Link field?

Private Sub refreshbp_Click()
    Dim dbs As DAO.Database
    Dim rsQuery As DAO.Recordset
    Dim sPath As String, sFile As String
      Set dbs = CurrentDb

    'Open a dynaset-type Recordset using a saved query
    Set rsQuery = dbs.OpenRecordset("qrybrunning", dbOpenDynaset)
    With rsQuery
        Do While Not .EOF
            sPath = !Link & ""
            If Len(sPath)<>0 Then
                sPath = Split(sPath, "#")(1)
                If InStr(1, sPath, "\") = 0 Then
                    sPath = Environ$("userprofile") & "\documents\" & sFile
                End If
                On Error Resume Next
                sFile = Mid$(sPath, InStrRev(sPath, "\") + 1)
                Kill "S:\ProdSpecs\Active\" & sFile
                On Error GoTo 0
                FileCopy sPath, "S:\ProdSpecs\Active\" & sFile
            End If
            .MoveNext
        Loop
        .Close
    End With
    Set rsQuery = Nothing
    Set dbs = Nothing
End Sub

 

[laffeg]

yes it was missing the .Address part of the hyperlink - now sorted that and getting file not found error on the filecopy line

can you explain the logic of the sting parts ?

the hyperlinks all point to another folder on the S drive - I changed your Environ$ line to the source folder

 

[arnelgp]

modified again:

Private Sub refreshbp_Click()
    Dim dbs As DAO.Database
    Dim rsQuery As DAO.Recordset
    Dim sPath As String, sFile As String
    Dim var
    Set dbs = CurrentDb

    'Open a dynaset-type Recordset using a saved query
    Set rsQuery = dbs.OpenRecordset("qrybrunning", dbOpenDynaset)
    With rsQuery
        Do While Not .EOF
            sPath = !Link & ""
            If Len(sPath) <> 0 Then
                var = Split(sPath, "#")
                ' check if we have the Address part
                If UBound(var) > 0 Then
                    sPath = var(1)
                    If InStr(1, sPath, "\") = 0 Then
                        sPath = Environ$("userprofile") & "\documents\" & sFile
                    End If
                    ' check if the source file still exists
                    If Len(Dir$(sPath)) <> 0 Then
                        sFile = Mid$(sPath, InStrRev(sPath, "\") + 1)
                        On Error Resume Next
                        ' delete the target file if already exists
                        Kill "S:\ProdSpecs\Active\" & sFile
                        On Error GoTo 0
                        ' copy the source file to target file
                        FileCopy sPath, "S:\ProdSpecs\Active\" & sFile
                    Else
                        Debug.Print "file not found: " & sPath
                    End If
                End If
            End If
            .MoveNext
        Loop
        .Close
    End With
    Set rsQuery = Nothing
    Set dbs = Nothing
End Sub

 

[laffeg]

bingo ! that's great, thanks for the help