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()
 
   'hConnection schließen
   InternetCloseHandle hConnection
 
   'hOpen schließen
   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
 
   'Wenn Login erfolgreich
   If FTPLogin(strServer, strBenutzer, strPasswort) Then
 
     'Entweder Download der Datei
     If FTPDownload(strLokalerPfad, strRemotePfad) Then
        DoCmd.Hourglass False
        MsgBox "FTP-Download erfolgreich."
     Else
        DoCmd.Hourglass False
        MsgBox "FTP-Download nicht erfolgreich."
     End If
 
  '   'oder Upload der Datei
  '   If FTPUpload(strLokalerPfad, strRemotePfad) Then
  '      DoCmd.Hourglass False
  '      MsgBox "FTP-Upload erfolgreich."
  '   Else
  '      DoCmd.Hourglass False
  '      MsgBox "FTP-Upload nicht erfolgreich."
  '   End If
 
   End If
 
   'Logout
   Call FTPLogout