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.

'Quelle: http://www.dbwiki.net/
 
Option Explicit
 
 
'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    As Long = 21          'Standardwert für FTP-Server (nServerPort)
Private Const INTERNET_INVALID_PORT_NUMBER As Long = 0           'alternativ für nServerPort
Private Const INTERNET_SERVICE_FTP         As Long = 1           'lService
Private Const INTERNET_FLAG_PASSIVE        As Long = &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        As Long = &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 Long
 
'FtpPutFile (Datei hinaufladen)
Const FTP_TRANSFER_TYPE_UNKNOWN As Long = &H0  'dwFlags
Const FTP_TRANSFER_TYPE_ASCII   As Long = &H1  'dwFlags
Const FTP_TRANSFER_TYPE_BINARY  As Long = &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 Long
 
'InternetCloseHandle (Internethandle schließen)
Private Declare Function InternetCloseHandle Lib "wininet.dll" ( _
   ByVal hInet As Long) As Long
 
 
'Variablen für die Internetverbindung
Private hOpen As Long
Private hConnection As Long
 
 
Public Function FTPLogin(Server As String, _
                         Benutzer As String, _
                         Passwort As String) As Long
 
   'Internetverbindung herstellen
   hOpen = InternetOpen("EineVerbindung", 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
 
   'wenn hOpen geöffnet, schließen
   If hOpen Then InternetCloseHandle hOpen
 
   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.eine-domain.de"
   strBenutzer = "12345678"
   strPasswort = "geheim"
   strDateiname = "EineDatei.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