Εμφάνιση ενός μόνο μηνύματος
  #4  
Παλιά 10-05-13, 22:16
Το avatar του χρήστη Tasos
Tasos Ο χρήστης Tasos δεν είναι συνδεδεμένος
Διαχειριστής
Όνομα: Τάσος Φιλοξενιδης
Έκδοση λογισμικού Office: Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική
 
Εγγραφή: 21-10-2009
Μηνύματα: 2.035
Προεπιλογή

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

Δοκίμασε:

Κώδικας:
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 Development Team
Ανάπτυξη επαγγελματικών εφαρμογών