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