AW: Selektiver Download von ftp-Server
16.04.2008 22:24:50
ftp-Server
Hallo Andi,
ich habe erst vor einiger Zeit was zusammengebastelt für meine Zwecke.
statt mget *.* lädtst du mit VBA nur die, Dateien, die du brauchst.
Dazu kannst du die UDF Download(url As String, pfad As String, Optional ErrMsg = 1) nutzen:
Option Explicit
Public Declare Function URLDownloadToFile _
Lib "urlmon" Alias "URLDownloadToFileA" _
(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 DeleteUrlCacheEntry _
Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" _
(ByVal lpszUrlName As String) As Long
Public Enum URLDownloadErrConstants
udErrAborted = &H80004004
udErrDestFileExists = &H800C0001
udErrInvalidUrl = &H800C0002
udErrNoSession = &H800C0003
udErrCannotConnect = &H800C0004
udErrResourceNotFound = &H800C0005
udErrObjectNotFound = &H800C0006
udErrDataNotAvailable = &H800C0007
udErrDownloadFailure = &H800C0008
udErrAuthenticationRequired = &H800C0009
udErrNoValidMedia = &H800C000A
udErrConnectionTimeout = &H800C000B
udErrInvalidRequest = &H800C000C
udErrUnknownProtocol = &H800C000D
udErrSecurityProblem = &H800C000E
udErrCannotLoadData = &H800C000F
udErrCannotInstantiateObject = &H800C0010
udErrRedirectFailed = &H800C0014
udErrRedirectToDir = &H800C0015
udErrCannotLockRequest = &H800C0016
End Enum
Public Function Dateiname(ByVal url As String) As String
Dim i As Integer
i = InStrRev(url, "/")
If i > 0 Then
Dateiname = Mid(url, i + 1)
Else
Dateiname = url
End If
End Function
' Funktion Download(url As String, pfad as string, Optional ErrMsg = 1)
' url: URL zur Datei, z.B. "http://domain.de/verz/ _
datei.txt"
' (Achtung: relevante Groß-/Kleinschreibung!)
' pfad: lokales Zielverzeichnis oder Zieldatei, z.B.
' "C:\test\": Download in den Ordner, Name wie auf dem Server
' "C:\test\123.txt": Dateiname wird neu angegeben
' ErrMsg: =0, dann werden Fehlermeldungen unterdrückt
' Rückgabewert: True:Erfolg, False:Fehler beim Download
' ACHTUNG: lokale Dateien werden ohne Rückfrage überschrieben!
Function Download(url As String, pfad As String, Optional ErrMsg = 1)
Dim rc As Long, rcmsg As String
Dim dest As String
If Right(pfad, 1) = ":" Then pfad = pfad & "\" 'aus "C:" mach "C:\"
If Right(pfad, 1) = "\" Then
'Pfad angegeben
dest = pfad & Dateiname(url)
Else
'Datei angegeben
dest = pfad
End If
rc = DeleteUrlCacheEntry(url)
rc = URLDownloadToFile(0, url, dest, 0, 0)
If rc Then
Select Case rc
Case URLDownloadErrConstants.udErrAborted: rcmsg = "Aborted"
Case URLDownloadErrConstants.udErrAuthenticationRequired: rcmsg = "Authentication _
Required"
Case URLDownloadErrConstants.udErrCannotConnect: rcmsg = "Cannot Connect"
Case URLDownloadErrConstants.udErrCannotInstantiateObject: rcmsg = "Cannot Instantiate _
Object"
Case URLDownloadErrConstants.udErrCannotLoadData: rcmsg = "Cannot Load Data"
Case URLDownloadErrConstants.udErrCannotLockRequest: rcmsg = "Cannot Lock Request"
Case URLDownloadErrConstants.udErrConnectionTimeout: rcmsg = "Connection Timeout"
Case URLDownloadErrConstants.udErrDataNotAvailable: rcmsg = "Data Not Available"
Case URLDownloadErrConstants.udErrDestFileExists: rcmsg = "DestFile Exists"
Case URLDownloadErrConstants.udErrDownloadFailure: rcmsg = "Download Failure"
Case URLDownloadErrConstants.udErrInvalidRequest: rcmsg = "Invalid Request"
Case URLDownloadErrConstants.udErrInvalidUrl: rcmsg = "Invalid URL"
Case URLDownloadErrConstants.udErrNoSession: rcmsg = "No Session"
Case URLDownloadErrConstants.udErrNoValidMedia: rcmsg = "No Valid Media"
Case URLDownloadErrConstants.udErrObjectNotFound: rcmsg = "Object Not Found"
Case URLDownloadErrConstants.udErrRedirectFailed: rcmsg = "Redirect Failed"
Case URLDownloadErrConstants.udErrRedirectToDir: rcmsg = "Redirect To Dir"
Case URLDownloadErrConstants.udErrResourceNotFound: rcmsg = "Resource Not Found"
Case URLDownloadErrConstants.udErrSecurityProblem: rcmsg = "Security Problem"
Case URLDownloadErrConstants.udErrUnknownProtocol: rcmsg = "Unknown Protocol"
Case Else: rcmsg = "Unknown Error"
End Select
If ErrMsg Then MsgBox "Fehler beim Herunterladen: 0x" & Hex(rc) & " " & rcmsg, vbCritical
Download = False
Else
Download = True
End If
End Function
Viel Erfolg,
Matthias