VBA Tipp: Datei-Download und -Upload (FTP)

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

Ich möchte eine Datei von einem Internet-Server herunterladen bzw. auf einen Internet-Server hinaufladen.

Lösung

Das geht mit den folgenden API-Funktionen und VBA-Funktionen, die in einem globalen Modul hinterlegt werden.

'Variablen für die Internetverbindung
Private hOpen As Long
Private hConnection As Long
 
'InternetOpen (Internet öffnen)
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
Private Const INTERNET_OPEN_TYPE_PROXY As Long = 3
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
                         ByVal lpszAgent As String, _
                         ByVal dwAccessType As Long, _
                         ByVal lpszProxyName As String, _
                         ByVal lpszProxyBypass As String, _
                         ByVal dwFlags As Long _
                         ) As Long
 
'InternetConnect (Verbindung zum FTP-Server aufbauen)
Private Const INTERNET_DEFAULT_FTP_PORT = 21      'Standardwert für FTP-Server (nServerPort)
Private Const INTERNET_INVALID_PORT_NUMBER = 0    'alternativ für nServerPort
Private Const INTERNET_SERVICE_FTP = 1            'lService
Private Const INTERNET_FLAG_PASSIVE = &H8000000   'lFlags
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
                         ByVal hOpen As Long, _
                         ByVal sServerName As String, _
                         ByVal nServerPort As Integer, _
                         ByVal sUsername As String, _
                         ByVal sPassword As String, _
                         ByVal lService As Long, _
                         ByVal lFlags As Long, _
                         ByVal lContext As Long _
                         ) As Long
 
'FtpGetFile (Datei herunterladen)
Private Const FILE_ATTRIBUTE_NORMAL = &H80      'dwFlagsAndAttributes
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" ( _
                         ByVal hConnect As Long, _
                         ByVal lpszRemoteFile As String, _
                         ByVal lpszNewFile As String, _
                         ByVal fFailIfExists As Long, _
                         ByVal dwFlagsAndAttributes As Long, _
                         ByVal dwFlags As Long, _
                         ByRef dwContext As Long _
                         ) As Boolean
 
'FtpPutFile (Datei hinaufladen)
Const FTP_TRANSFER_TYPE_UNKNOWN = &H0 'dwFlags
Const FTP_TRANSFER_TYPE_ASCII = &H1   'dwFlags
Const FTP_TRANSFER_TYPE_BINARY = &H2  'dwFlags
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
                         ByVal hConnect As Long, _
                         ByVal lpszLocalFile As String, _
                         ByVal lpszNewRemoteFile As String, _
                         ByVal dwFlags As Long, _
                         ByVal dwContext As Long _
                         ) As Boolean
 
'InternetCloseHandle (Internethandle schließen)
Private Declare Function InternetCloseHandle Lib "wininet.dll" ( _
                         ByVal hInet As Long _
                         ) As Integer
 
 
Public Function FTPLogin(ByVal Server As String, _
                         ByVal Benutzer As String, _
                         ByVal Passwort As String _
                         ) As Long
 
 'Internetverbindung herstellen
 hOpen = InternetOpen("MeineVerbindung", INTERNET_OPEN_TYPE_PRECONFIG, _
                          vbNullString, vbNullString, 0)
 
 If hOpen = 0 Then
   'Fehlermeldung
     MsgBox "Fehler beim Aufbau der Internetverbindung!"
   Exit Function
 End If
 
 'Verbindung zum FTP-Server
 hConnection = InternetConnect(hOpen, Server, INTERNET_DEFAULT_FTP_PORT, _
                             Benutzer, Passwort, INTERNET_SERVICE_FTP, _
                             INTERNET_FLAG_PASSIVE, 0)
 
 'wenn Verbindung zum FTP-Server nicht herstellbar
 If hConnection = 0 Then
   'Fehlermeldung
   MsgBox "Es konnte keine Verbindung zum FTP-Server hergestellt werden!" _
          & vbCrLf & vbCrLf & "Mögliche Ursache:" _
          & vbCrLf & "Es besteht keine Internetverbindung."
   Exit Function
 End If
 
 'Rückgabewert
 FTPLogin = hConnection
 
End Function
 
 
Public Function FTPUpload(ByVal LokaleDatei As String, ByVal RemoteDatei As String) As Long
 
 FTPUpload = FtpPutFile(hConnection, LokaleDatei, RemoteDatei, FTP_TRANSFER_TYPE_UNKNOWN, 0)
 
End Function
 
 
Public Function FTPDownload(ByVal LokaleDatei As String, ByVal RemoteDatei As String) As Long
 
 FTPDownload = FtpGetFile(hConnection, RemoteDatei, LokaleDatei, 0, _
                          FILE_ATTRIBUTE_NORMAL, FTP_TRANSFER_TYPE_UNKNOWN, 0)
 
End Function
 
 
Public Sub FTPLogout()
 
 'wenn hConnection geöffnet, schließen
 If hConnection Then
   InternetCloseHandle hConnection
End If
 
 'wenn hOpen geöffnet, schließen
 If hOpen Then
   InternetCloseHandle hOpen
 End If
 
 DoCmd.Hourglass False
 
End Sub

Aufruf

Wahlweise entweder Download oder Upload einer Datei:

 Dim strServer As String
 Dim strBenutzer As String
 Dim strPasswort As String
 Dim strDateiname As String
 Dim strLokalerPfad As String
 Dim strRemotePfad As String
 
 strServer = "www.meine-domain.de"
 strBenutzer = "12345678"
 strPasswort = "geheim"
 strDateiname = "MeineDatei.zip"
 strLokalerPfad = CurrentProject.Path & "\" & strDateiname
 'Relativer Pfad zum Remote-Ordner mit Dateiname
 strRemotePfad = "htdocs/test/" & strDateiname
 
 DoCmd.Hourglass True
 
 'Login
 If FTPLogin(strServer, strBenutzer, strPasswort) = 0 Then
   Call FTPLogout
   Exit Sub
 End If
 
 'Entweder Download der Datei
 If Not FTPDownload(strLokalerPfad, strRemotePfad) = 0 Then
   DoCmd.Hourglass False
   MsgBox "FTP-Download erfolgreich."
 Else
   DoCmd.Hourglass False
   MsgBox "FTP-Download nicht erfolgreich."
 End If
 
' 'oder Upload der Datei
' If Not FTPUpload(strLokalerPfad, strRemotePfad) = 0 Then
'   DoCmd.Hourglass False
'   MsgBox "FTP-Upload erfolgreich."
' Else
'   DoCmd.Hourglass False
'   MsgBox "FTP-Upload nicht erfolgreich."
' End If
 
 'Logout
 Call FTPLogout