Download Photo από web

[dmarop]

Καλησπέρα και Χρόνια Πολλά!

Θα χρειαστώ για άλλη μια φορά την βοήθειά σας. Έχω ένα πίνακα σε access και σε ένα πεδίο έχω ένα link με φωτογραφίες π.χ. http://asfalies24.gr/images/test_image.jpg

Υπάρχει τρόπος να φτιαχτεί κάποιο vbscript ώστε να κάνω download την συγκεκριμένη φωτογραφία σε συγκεκριμένο folder στον δίσκο μου;

Σας έχω επισυνάψει και ένα παράδειγμα της βάσης.

Ευχαριστώ,
Δημήτρης

[Tasos]

Καλημέρα!

Δημήτρη, το συνημμένο παράδειγμα νομίζω ότι θα σε βοηθήσει.

Δοκίμασε και με περισσότερες καταχωρήσεις διευθύνσεων Web στον πίνακα.

Καλή συνέχεια!

Τάσος

[dmarop]

Καλησπέρα Τάσο,

Ευχαριστώ για την απάντησή σου. Θα χρειαστώ μια μικρή διόρθωση στο εξής:

DirPath = CurrentProject.Path & "\gallery\"

Στη θέση του \gallery\ θέλω να παίρνει την τιμή του πεδίου dlfolder του πίνακα, γιατί θέλω να αρχειοθετώ τα αρχεία σε διαφορετικούς φακέλους.

Να είσαι καλά!

Φιλικά,
Δημήτρης

[Tasos]

Καλησπέρα Δημήτρη!

Δοκίμασε:

Sub DownloadIcons(lbl As Access.Label)
    Dim oField As DAO.Field, oField1 As DAO.Field, fso As Object
    Dim Ret As Long, i As Integer, ofile As Object
    Dim rs As DAO.Recordset
    Dim DirPath As String
    Dim LocalFileName As String
    Dim RemoteFileName As String
    Dim IMGCount As Long
    Dim tblName As String

    tblName = "Test-img"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set rs = CurrentDb.OpenRecordset(tblName, dbOpenDynaset)
    If rs.RecordCount Then
        rs.MoveLast
        rs.MoveFirst
    Else
        Exit Sub
    End If
    On Error GoTo ExitHere
    IMGCount = rs.RecordCount
    Set oField = rs.Fields("linkimg")
    Set oField1 = rs.Fields("dlfolder")
    While Not rs.EOF
        DoEvents
        If StopProcedure Then GoTo ExitHere
        If Len(Nz(oField, "")) And Len(Nz(oField1, "")) Then
            RemoteFileName = oField.Value
            DirPath = oField1.Value
            If Not fso.FolderExists(DirPath) Then
                On Error Resume Next
                fso.CreateFolder DirPath
                On Error GoTo ExitHere
                If Err = 0 Then
                    DirPath = IIf(Right(DirPath, 1) = "\", DirPath, DirPath & "\")
                    LocalFileName = DirPath & Mid(RemoteFileName, InStrRev(RemoteFileName, "/") + 1)
                    If Not fso.FileExists(LocalFileName) Then
                        Ret = URLDownloadToFileA(0, RemoteFileName, LocalFileName, 0, 0)
                        If Ret = 0 Then
                            i = i + 1
                            lbl.Caption = "Downloaded: " & i & " from " & IMGCount & " images"
                        End If
                    End If
                End If
            End If
        End If
        rs.MoveNext
    Wend
ExitHere:
    If Err <> 0 And Err <> 380 Then
        MsgBox Err.Number & " " & vbLf & Err.Description
    End If
    On Error Resume Next
    rs.Close
    Set rs = Nothing
End Sub

Καλή συνέχεια!

Τάσος

[dmarop]

Καλησπέρα!

Δοκίμασα τον κώδικα όμως δεν δουλεύει.

Προσπάθησα να βάλω τα πεδία μέσα στη φόρμα και πάλι δεν δούλεψε.

Σου επισυνάπτω την βάση με πιο πολλά δεδομένα. Θα με βοηθούσες πολύ αν έχεις την καλοσύνη να την ξαναδείς.

Ευχαριστώ,
Δημήτρης

[Tasos]

Καλημέρα Δημήτρη!
Δοκίμασε το παρακάτω (Όλος ο κώδικας της λειτουργικής μονάδας ; Για Εκδόσεις ms - Office 32bit):

Option Compare Database
Option Explicit

Private Declare Function URLDownloadToFileA Lib "urlmon" ( _
                                            ByVal pCaller As Long, _
                                            ByVal szURL As String, ByVal szFileName As String, _
                                            ByVal dwReserved As Long, _
                                            ByVal lpfnCB As Long) As Long

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp" (ByVal DirPath As String) As Long

Public StopProcedure As Boolean

Sub DownloadIcons(lbl As Access.Label)
    Dim oField As DAO.Field, oField1 As DAO.Field, fso As Object
    Dim Ret As Long, i As Integer, ofile As Object
    Dim rs As DAO.Recordset
    Dim DirPath As String
    Dim LocalFileName As String
    Dim RemoteFileName As String
    Dim IMGCount As Long
    Dim tblName As String

    tblName = "Test-img"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set rs = CurrentDb.OpenRecordset(tblName, dbOpenDynaset)
    If rs.RecordCount Then
        rs.MoveLast
        rs.MoveFirst
    Else
        Exit Sub
    End If
    On Error GoTo ExitHere
    IMGCount = rs.RecordCount
    Set oField = rs.Fields("linkimg")
    Set oField1 = rs.Fields("dlfolder")

    While Not rs.EOF
        DoEvents
        If StopProcedure Then GoTo ExitHere
        If Len(Nz(oField, "")) > 0 And Len(Nz(oField1, "")) > 0 Then
            RemoteFileName = oField.Value
            DirPath = oField1.Value
            DirPath = IIf(Right(DirPath, 1) = "\", DirPath, DirPath & "\")
            Ret = MakeSureDirectoryPathExists(DirPath)
            If Ret <> 1 Then GoTo NextStep
            LocalFileName = DirPath & Mid(RemoteFileName, InStrRev(RemoteFileName, "/") + 1)
            If Not fso.FileExists(LocalFileName) Then
                Ret = URLDownloadToFileA(0, RemoteFileName, LocalFileName, 0, 0)
                If Ret = 0 Then
                    i = i + 1
                    lbl.Caption = "Downloaded: " & i & " from " & IMGCount & " images"
                End If
            End If
        End If
        rs.MoveNext
NextStep:
    Wend
ExitHere:
    If Err <> 0 And Err <> 380 Then
        MsgBox Err.Number & " " & vbLf & Err.Description
    End If
    On Error Resume Next
    rs.Close
End Sub

Φιλικά

Τάσος

[dmarop]

Καλησπέρα Τάσο,

Ευχαριστώ άλλη μια φορά για την βοήθειά σου, ήταν πολύ χρήσιμη.

Φιλικά,

Δημήτρης