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

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

  • Ich möchte eine Datei von einem Internet-Server herunterladen bzw. auf einen Internet-Server hinaufladen.
  • Der laufende Fortschritt des Downloads bzw. Uploads kann über eine Progressbar (Fortschrittsanzeige) angezeigt werden. Die im untenstehenden Code verwendete Progressbar kann im DBWiki heruntergeladen werden unter: Datei:Progressbars.zip
  • Der Zugang zum Internet-Verzeichnis erfolgt über das FTP-Protokoll.
  • Für den FTP-Zugang zum Server ist ein Benutzername und ein Passwort erforderlich.

Lösung

Das geht mit den folgenden API-Funktionen und VBA-Funktionen, die in einem allgemeinen (globalen) Modul gespeichert werden. Der Dateiname im Quellverzeichnis darf unterschiedlich zum Dateinamen im Zielverzeichnis sein.

Option Explicit
 
' Quelle: http://www.dbwiki.net/
 
' Variable für die Progressbar Typ 1 oder alternativ Typ 2 (falls verwendet)
' Download-Möglichkeit der Progressbars unter http://dbwiki.net/wiki/Datei:Progressbars.zip
' Falls die Progressbars importiert wurden, bringen sie die Variable 'CancelProgBar' bereits mit,
' und dann muss die Variable an dieser Stelle auskommentiert bzw. gelöscht werden.
Public CancelProgBar As Boolean
 
' Variablen für die Internetverbindung
Private hOpen        As Long
Private hConnection  As Long
Private hFile        As Long
Private hFind        As Long
 
 
' Konstanten
 
' Für InternetReadFile
' MAX_BUFFER auf die aktuelle Internetgeschwindigkeit setzen, z.B. 3.000 kbit/s
Private Const MAX_BUFFER As Long = 3000
 
' Für FtpFindFirstFile
' Für Private Type WIN32_FIND_DATA
Private Const MAX_PATH As Long = 260
 
' Für Private Type WIN32_FIND_DATA
Private Type FILETIME
   dwLowDateTime   As Long
   dwHighDateTime  As Long
End Type
 
' Für FtpFindFirstFile,
' Für InternetFindNextFile
Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime   As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime  As FILETIME
   nFileSizeHigh    As Long
   nFileSizeLow     As Long
   dwReserved0      As Long
   dwReserved1      As Long
   cFileName        As String * MAX_PATH
   cAlternate       As String * 14
End Type
 
' Für InternetOpen
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
Private Const INTERNET_OPEN_TYPE_DIRECT    As Long = 1
 
' Für InternetConnect
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
 
' Für FtpOpenFile
Private Const GENERIC_WRITE             As Long = &H40000000
Private Const GENERIC_READ              As Long = &H80000000
Private Const FTP_TRANSFER_TYPE_UNKNOWN As Long = &H0  ' Setzt FTP_TRANSFER_TYPE_BINARY als Standard
Private Const FTP_TRANSFER_TYPE_ASCII   As Long = &H1  ' ASCI-Übertragung
Private Const FTP_TRANSFER_TYPE_BINARY  As Long = &H2  ' Binäre Übertragung
 
 
' API-Funktionen
 
' Internet öffnen
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
 
' Verbindung zum FTP-Server herstellen
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
 
' FTP-Hauptverzeichnis holen
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" _
   Alias "FtpGetCurrentDirectoryA" ( _
   ByVal hConnect As Long, _
   ByVal lpszCurrentDirectory As String, _
   ByRef lpdwCurrentDirectory As Long) As Long
 
' Zum FTP-Unterverzeichnis wechseln
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" _
   Alias "FtpSetCurrentDirectoryA" ( _
   ByVal hConnect As Long, _
   ByVal lpszDirectory As String) As Long
 
' Erste Datei im FTP-Unterverzeichnis finden
Private Declare Function FtpFindFirstFile Lib "wininet.dll" _
   Alias "FtpFindFirstFileA" ( _
   ByVal hConnect As Long, _
   ByVal lpszSearchFile As String, _
   ByRef lpFindFileData As WIN32_FIND_DATA, _
   ByVal dwFlags As Long, _
   ByVal dwContent As Long) As Long
 
' Nächste Datei im FTP-Unterverzeichnis finden
Private Declare Function InternetFindNextFile Lib "wininet.dll" _
   Alias "InternetFindNextFileA" ( _
   ByVal hFind As Long, _
   ByRef lpvFindData As WIN32_FIND_DATA) As Long
 
' Internet-Datei öffnen oder neu anlegen, schreibender oder lesender Zugriff
Private Declare Function FtpOpenFile Lib "wininet.dll" _
   Alias "FtpOpenFileA" ( _
   ByVal hConnect As Long, _
   ByVal lpszFileName As String, _
   ByVal dwAccess As Long, _
   ByVal dwFlags As Long, _
   ByRef dwContext As Long) As Long
 
' Inhalt einer Internet-Datei lesen
Private Declare Function InternetReadFile Lib "wininet.dll" ( _
   ByVal hFile As Long, _
   ByVal lpBuffer As String, _
   ByVal dwNumberOfBytesToRead As Long, _
   ByRef lpdwNumberOfBytesRead As Long) As Long
 
' In Internet-Datei schreiben
Private Declare Function InternetWriteFile Lib "wininet.dll" ( _
   ByVal hFile As Long, _
   ByRef lpBuffer As Byte, _
   ByVal dwNumberOfBytesToWrite As Long, _
   ByRef lpdwNumberOfBytesWritten As Long) As Long
 
' Internet-Datei löschen
Private Declare Function FtpDeleteFile Lib "wininet.dll" _
   Alias "FtpDeleteFileA" ( _
   ByVal hFtpSession As Long, _
   ByVal lpszFileName As String) As Long
 
' Internethandle schließen
Private Declare Function InternetCloseHandle Lib "wininet.dll" ( _
   ByVal hInet As Long) As Long
 
 
Public Function FTPLogin(Server As String, _
                         Benutzer As String, _
                         Passwort As String, _
                         Optional RelativerOrdnerpfad As String, _
                         Optional OhneFehlerMeldung As Boolean) As Long
 
   Dim strOrgPfad           As String
   Dim lngRoot              As Long
   Dim lngUnterverzeichnis  As Long
 
   ' Internetverbindung herstellen
 
   ' Statusmeldung, wenn das Formular "WF_Progressbar1" geöffnet ist
   If CurrentProject.AllForms("WF_Progressbar1").IsLoaded Then
     Call Progressbar1(, "Internetverbindung wird hergestellt ...")
   End If
 
   hOpen = InternetOpen("EineVerbindung", INTERNET_OPEN_TYPE_PRECONFIG, _
                        vbNullString, vbNullString, 0)
 
   If hOpen = 0 Then
      ' Fehlermeldung
      If OhneFehlerMeldung = False Then _
         MsgBox "Fehler beim Aufbau der Internetverbindung!"
      Exit Function
   End If
 
   ' Verbindung zum FTP-Server herstellen
 
   ' Statusmeldung, wenn das Formular "WF_Progressbar1" geöffnet ist
   If CurrentProject.AllForms("WF_Progressbar1").IsLoaded Then
     Call Progressbar1(, "Verbindung zum FTP-Server wird hergestellt ...")
   End If
 
   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
      If OhneFehlerMeldung = False Then
         MsgBox "Es konnte keine Verbindung zum FTP-Server hergestellt werden!" & _
                vbCrLf & vbCrLf & "Mögliche Ursache:" & _
                vbCrLf & "Es besteht keine Internetverbindung."
      End If
      Exit Function
   End If
 
   ' Das Rootverzeichnis holen
 
   ' Einen Puffer erzeugen, um das Rootverzeichnis zu speichern
   strOrgPfad = String(MAX_PATH, 0)
 
   lngRoot = FtpGetCurrentDirectory(hConnection, strOrgPfad, Len(strOrgPfad))
 
   ' Wenn Verbindung zum Rootverzeichnis nicht herstellbar
   If lngRoot = 0 Then
      ' Fehlermeldung
      If OhneFehlerMeldung = False Then _
         MsgBox "Fehler beim Zugriff auf das Hauptverzeichnis!"
      Exit Function
   End If
 
   ' Das aktuelle Verzeichnis auf den Unterordner setzen
 
   ' Ggf. Slash am Pfadende hinzufügen, sonst Fehler. Slash am Pfadanfang ist egal.
   If Not Right(RelativerOrdnerpfad, 1) = "/" Then
      RelativerOrdnerpfad = RelativerOrdnerpfad & "/"
   End If
 
   lngUnterverzeichnis = FtpSetCurrentDirectory(hConnection, RelativerOrdnerpfad)
 
   ' Wenn Verbindung zum Unterverzeichnis nicht herstellbar
   If lngUnterverzeichnis = 0 Then
      ' Fehlermeldung
      If OhneFehlerMeldung = False Then
         MsgBox "Fehler beim Zugriff auf das Unterverzeichnis !"
         Exit Function
      End If
   End If
 
   ' Rückgabewert
   FTPLogin = lngUnterverzeichnis
 
End Function
 
 
Private Function FTPDateiOeffnen(ByVal RemoteDateiname As String, _
                                 ByVal Modus As Long)
 
   ' Quelle: http://www.dbwiki.net/
 
   ' Vorhandene Datei auf dem FTP-Server öffnen oder neue Datei anlegen
   hFile = FtpOpenFile(hConnection, RemoteDateiname, _
                       Modus, FTP_TRANSFER_TYPE_UNKNOWN, 0)
 
   ' Wenn die Datei nicht geöffnet/angelegt werden kann
   If hFile = 0 Then
      ' Fehlermeldung
      MsgBox "Fehler beim Zugriff auf die Internet-Datei!" & _
             vbCrLf & vbCrLf & "Mögliche Ursache:" & _
             vbCrLf & "Der Pfad zur Internetdatei ist ungültig."
      Exit Function
   End If
 
   FTPDateiOeffnen = hFile
 
End Function
 
 
Public Function FTPDownload(PfadLokaleDatei As String, _
                            RemoteDateiname As String, _
                            Optional Statusmeldung As String) As Boolean
 
   ' Quelle: http://www.dbwiki.net/
 
   Dim lngDateiGroesse    As Long
   Dim strBuffer          As String
   Dim ByteAnz            As Long
   Dim strPfadRemoteDatei As String
   Dim strDateiinhalt     As String
   Dim pData              As WIN32_FIND_DATA
   Dim lngread            As Long
   Dim d                  As Integer
 
   On Error GoTo Err_FTPDownload
 
   ' Dateigröße ermitteln
 
   ' Einen Puffer erzeugen
   pData.cFileName = String$(MAX_PATH, 0)
 
   ' Die erste Datei im aktuellen Ordner (hConnection) suchen
   hFind = FtpFindFirstFile(hConnection, RemoteDateiname, pData, 0, 0)
 
   ' Dateigröße speichern
   lngDateiGroesse = pData.nFileSizeLow
 
   ' Wenn die Datei nicht gefunden wird
   If hFind = 0 Then
     ' Fehlermeldung
     MsgBox "Die Internetdatei existiert nicht!"
     GoTo Exit_FTPDownload
   End If
 
   ' Die Datei auf dem FTP-Server öffnen
   If FTPDateiOeffnen(RemoteDateiname, GENERIC_READ) = 0 Then
     GoTo Exit_FTPDownload
   End If
 
   ' Downloadvorgang
 
   ' Statusmeldung, wenn das Formular "WF_Progressbar1" geöffnet ist
   If CurrentProject.AllForms("WF_Progressbar1").IsLoaded Then
     If Len(Statusmeldung) = 0 Then
       Call Progressbar1(, RemoteDateiname & " wird heruntergeladen ...")
     Else
       Call Progressbar1(, Statusmeldung)
     End If
   End If
 
   ' strBuffer mit Leerzeichen vorbelegen (Internetgeschwindigkeit * 8)
   strBuffer = Space$(MAX_BUFFER * 8)
 
   ' Download, bis die Progressbar vom Benutzer geschlossen wird
   Do Until CancelProgBar
 
      ' strBuffer enthält die aktuell gelesenen Daten aus der Datei
      ' Len(strBuffer) = Größe des aktuellen Puffers
      ' ByteAnz = Anzahl der aktuell in den Puffer eingelesenen Bytes(=Zeichen)
      lngread = InternetReadFile(hFile, strBuffer, Len(strBuffer), ByteAnz)
 
      ' Der Download ist beendet, wenn ByteAnz an dieser Stelle 0 ist
      If ByteAnz = 0 Then Exit Do
 
      If lngread = 0 Then
         ' Fehlermeldung
         MsgBox "Fehler beim Lesen der Internet-Datei!"
         Exit Do
      End If
 
      ' Dateiinhalt: Bufferinhalt in string einlesen und addieren
      strDateiinhalt = strDateiinhalt & Left$(strBuffer, ByteAnz)
 
      ' Bedienung der Progressbar (Formular "WF_Progressbar1")
      If CurrentProject.AllForms("WF_Progressbar1").IsLoaded Then
        Call Progressbar1(Len(strDateiinhalt) / lngDateiGroesse)
      End If
 
   Loop
 
 
   ' Heruntergeladene Daten in lokaler Datei speichern
 
   ' Wenn der Benutzer abgebrochen hat
   If CancelProgBar Then
      MsgBox "Der Download wurde abgebrochen!"
   Else
 
      ' Wenn Lesen erfolgreich
      If lngread Then
 
         ' Statusmeldung, wenn das Formular "WF_Progressbar1" geöffnet ist
         If CurrentProject.AllForms("WF_Progressbar1").IsLoaded Then
            Call Progressbar1(, "Datei wird gespeichert ...")
         End If
 
         ' Lokale Datei löschen, falls bereits vorhanden
         On Error Resume Next
         Kill PfadLokaleDatei
         On Error GoTo 0
 
         ' In lokale Datei schreiben
         d = FreeFile()
         Open PfadLokaleDatei For Output As d
         Print #d, strDateiinhalt;
         Close d
 
         ' Rückgabewert der Funktion setzen
         FTPDownload = True
 
      End If
 
   End If
 
Exit_FTPDownload:
 
   ' hFile schließen
   InternetCloseHandle hFile
 
   ' hFind schließen
   InternetCloseHandle hFind
 
   Exit Function
 
Err_FTPDownload:
 
   ' Standard-Fehlermeldung
   MsgBox "Laufzeitfehler '" & Err.Number & "':" & vbCrLf & vbLf & Err.Description
 
   Resume Exit_FTPDownload
 
End Function
 
 
Public Function FTPUpload(PfadLokaleDatei As String, _
                          RemoteDateiname As String, _
                          Optional Statusmeldung As String) As Boolean
 
   ' Quelle: http://www.dbwiki.net/
 
   Dim arrDaten()         As Byte
   Dim lngGeschrieben     As Long
   Dim lngDateiGroesse    As Long
   Dim ub                 As Long
   Dim UebertrageneBytes  As Long
   Dim lngZuSchreiben     As Long
   Dim lngWrite           As Long
   Dim lngBlockGroesse    As Long
   Dim fNum               As Integer
 
   On Error GoTo Err_FTPUpload
 
   ' Vorhandene Datei auf dem FTP-Server schreibend öffnen oder Datei neu anlegen
   If FTPDateiOeffnen(RemoteDateiname, GENERIC_WRITE) = 0 Then
     Exit Function
   End If
 
 
   ' Uploadvorgang
 
   ' Statusmeldung, wenn das Formular "WF_Progressbar1" geöffnet ist
   If CurrentProject.AllForms("WF_Progressbar1").IsLoaded Then
     If Len(Statusmeldung) = 0 Then
       Call Progressbar1(, RemoteDateiname & " wird hinaufgeladen ...")
     Else
       Call Progressbar1(, Statusmeldung)
     End If
   End If
 
   fNum = FreeFile()
   ' Lokale Quelldatei öffnen
   Open PfadLokaleDatei For Binary Access Read As fNum
 
   ' LOF = Größe einer geöffneten Datei in Bytes
   lngDateiGroesse = LOF(fNum)
 
   ' Dateiinhalt in Array einlesen
   ReDim arrDaten(0 To lngDateiGroesse) As Byte
   Get #fNum, , arrDaten()
 
   ' UebertrageneBytes enthält die Anzahl der bereits geschriebenen Bytes
   UebertrageneBytes = 0
 
   ' Größe des Arrays, Anzahl der Bytes
   ub = UBound(arrDaten)
 
   ' Blockgröße festlegen (Internetgeschwindigkeit * 2)
   lngBlockGroesse = MAX_BUFFER * 2
 
   ' Upload, solange Progressbar1 nicht geschlossen wird
   Do Until CancelProgBar
 
      If UebertrageneBytes + lngBlockGroesse <= ub Then
         ' Volle Blockgröße schreiben
         lngZuSchreiben = lngBlockGroesse
      Else
         ' Rest-Bytes am Schluß, die kleiner als lngBlockGroesse sind
         lngZuSchreiben = (ub - UebertrageneBytes)
      End If
 
      ' Der Upload ist beendet, wenn lngZuSchreiben an dieser Stelle 0 ist
      If lngZuSchreiben = 0 Then Exit Do
 
      ' In Internetdatei schreiben
      ' lngZuSchreiben: Anzahl der zu schreibenden Bytes
      ' lngGeschrieben: Anzahl der geschriebenen Bytes
      lngWrite = InternetWriteFile(hFile, arrDaten(UebertrageneBytes), _
                                   lngZuSchreiben, lngGeschrieben)
 
      If lngWrite = 0 Then
         ' Fehlermeldung
         MsgBox "Fehler beim Schreiben der Internet-Datei!"
         GoTo Exit_FTPUpload
      End If
 
      UebertrageneBytes = UebertrageneBytes + lngZuSchreiben
 
      ' Bedienung der Progressbar (Formular "WF_Progressbar1")
      If CurrentProject.AllForms("WF_Progressbar1").IsLoaded Then
         Call Progressbar1(UebertrageneBytes / lngDateiGroesse)
      End If
 
   Loop
 
   ' Wenn der Benutzer abgebrochen hat
   If CancelProgBar Then
      MsgBox "Der Upload wurde abgebrochen!"
   Else
      ' Wenn Schreiben erfolgreich
      If lngWrite Then
 
         ' Rückgabewert der Funktion
         FTPUpload = True
 
      End If
 
   End If
 
Exit_FTPUpload:
 
   ' Datei schließen
   Close fNum
 
   ' hFile schließen
   InternetCloseHandle hFile
 
   Exit Function
 
Err_FTPUpload:
 
   ' Standard-Fehlermeldung
   MsgBox "Laufzeitfehler '" & Err.Number & "':" & vbCrLf & vbLf & Err.Description
 
   Resume Exit_FTPUpload
 
End Function
 
 
Public Sub FTPLogout()
 
   ' Progressbar1 schließen, falls geöffnet
   DoCmd.Close acForm, "WF_Progressbar1"
 
   ' Progressbar2 schließen, falls geöffnet
   DoCmd.Close acForm, "WF_Progressbar2"
 
   ' hConnection schließen
   InternetCloseHandle hConnection
 
   ' hOpen schließen
   InternetCloseHandle hOpen
 
End Sub

Aufruf

Wahlweise entweder Download oder Upload einer Datei

   Dim strServer            As String
   Dim strBenutzer          As String
   Dim strPasswort          As String
   Dim strRemoteDateiname   As String
   Dim strLokalerDateipfad  As String
   Dim strStatusmeldung     As String
   Dim strRelRemotePfad     As String
 
   strServer = "www.eine-domain.de"
   strBenutzer = "12345678"
   strPasswort = "geheim"
   strRelRemotePfad = "htdocs/einunterordner/einunterunterordner"
   strRemoteDateiname = "EineDatei.pdf"
   strLokalerDateipfad = CurrentProject.Path & "\EineDatei.pdf"
 
   ' Progressbar Typ 1 öffnen, falls sie importiert wurde und verwendet werden soll
   ' Download-Möglichkeit der Progressbars unter http://dbwiki.net/wiki/Datei:Progressbars.zip
   DoCmd.OpenForm "WF_Progressbar1"
   Set frmPB1 = Forms!WF_Progressbar1
 
   ' Wenn Login erfolgreich
   If FTPLogin(strServer, strBenutzer, strPasswort, strRelRemotePfad) Then
 
      ' Entweder:
      ' Download einer Datei
      If FTPDownload(strLokalerDateipfad, strRemoteDateiname) = True Then
         MsgBox "Der Download war erfolgreich."
      Else
         MsgBox "Der Download war nicht erfolgreich."
      End If
 
'      ' Oder alternativ:
'      ' Upload einer Datei
'      If FTPUpload(strLokalerDateipfad, strRemoteDateiname) = True Then
'         MsgBox "Der Upload war erfolgreich."
'      Else
'         MsgBox "Der Upload war nicht erfolgreich."
'      End If
 
   End If
 
   ' Logout
   Call FTPLogout


Wiki hinweis.png

Anmerkung:

  • Wenn die herunter- bzw. hinaufgeladene Datei im Zielverzeichnis bereits besteht, wird sie ohne Vorwarnung überschrieben.
  • Die heruntergeladene Datei wird im Browser-Cache des Internet Explorer gespeichert. Mit Hilfe der API-Funktion DeleteUrlCacheEntry kann der Eintrag im Browser-Cache ggf. gelöscht werden.


Wikilinks

Weblinks