Forum - Download Photo από web

Forum (https://www.ms-office.gr/forum/)

- Access - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/)

- - Download Photo από web (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/2513-download-photo-apo-web.html)

Download Photo από web

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

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

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

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

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

Καλημέρα!

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

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

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

Τάσος

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

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

Κώδικας:

DirPath = CurrentProject.Path & "\gallery\"

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

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

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

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

Δοκίμασε:

Κώδικας:

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

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

Τάσος

Καλησπέρα!

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

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

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

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

Καλημέρα Δημήτρη!
Δοκίμασε το παρακάτω (Όλος ο κώδικας της λειτουργικής μονάδας ; Για Εκδόσεις 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

Φιλικά

Τάσος

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

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

Φιλικά,

Δημήτρης