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

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

Φιλικά

Τάσος
__________________
Ms-Office Development Team
Ανάπτυξη επαγγελματικών εφαρμογών