
10-05-13, 22:16
|
 | Διαχειριστής Όνομα: Τάσος Φιλοξενιδης Έκδοση λογισμικού 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 Ανάπτυξη επαγγελματικών εφαρμογών |