VBA Tipp: Alle Dateien aus einem Internetverzeichnis auslesen (FTP)

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

  • Ich möchte die Pfade und Namen aller Dateien aus einem Internetverzeichnis auslesen.
  • Wahlweise können zusätzlich die Pfade und Namen aller Dateien aus den Unterverzeichnissen mit ausgelesen werden. Leere Unterverzeichnisse werden nicht aufgelistet.
  • Der Zugang zu dem Internetverzeichnis erfolgt über das FTP-Protokoll.
  • Für den Zugang zum FTP-Server ist ein Benutzername und ein Passwort erforderlich.

Lösung

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

  • Die Funktion FTPLogin stellt die Verbindung zum FTP-Server her und verzweigt zum gewünschten Unterverzeichnis.
  • Die Funktion FTPDateipfadeAuslesen gibt ein Array mit allen Dateipfaden zurück.
  • Die Funktion FTPLogout trennt die Internetverbindung wieder.

Hinweis:
Das Auslesen der Dateipfade dauert ca. 10 ms pro Datei, d.h. bei 1000 Dateien läuft der Code ca. 10 Sekunden, bis das Ergebnis angezeigt wird. In solchen Fällen empfiehlt sich der Einsatz einer Fortschrittsanzeige oder das Einblenden eines Sanduhrsybols oder eines Meldungfensters Bitte warten ... .


Argumente der Funktion FTPDateipfadeAuslesen:

  • Ordnerpfad: Relativer Pfad zum Internetverzeichnis
  • MitUnterordner (Optional): Wenn True, werden zusätzlich die Pfade und Namen aller Dateien aus den Unterverzeichnissen mit aufgelistet.
Option Explicit
 
' Quelle: http://www.dbwiki.net/
 
' Konstanten
 
' 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
 
 
' 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
 
' Internethandle schließen
Private Declare Function InternetCloseHandle Lib "wininet.dll" ( _
   ByVal hInet As Long) As Long
 
 
' Variablen
Private hOpen       As Long
Private hConnection As Long
Private hFind       As Long
 
 
Public Function FTPLogin(ByVal Server As String, _
                         ByVal Benutzer As String, _
                         ByVal Passwort As String, _
                         Optional ByVal RelativerOrdnerpfad As String, _
                         Optional ByVal OhneFehlermeldung As Boolean) As Long
 
   Dim strOrgPfad           As String
   Dim lngRoot              As Long
   Dim lngUnterverzeichnis  As Long
 
   ' Internetverbindung herstellen
   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
   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."
      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
 
   ' Setzt das aktuelle Verzeichnis auf den Unterordner
 
   ' 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
 
 
Public Function FTPDateipfadeAuslesen(ByVal Ordnerpfad As String, _
                                      Optional ByVal MitUnterordner As Boolean) As Variant
 
 ' Quelle: http://www.dbwiki.net/
 
 Dim pData                As WIN32_FIND_DATA
 Dim lngfindnext          As Long
 Dim strDateiname         As String
 Dim i                    As Long
 Dim j                    As Long
 Dim k                    As Long
 Dim lngUnterverzeichnis  As Long
 Dim strAktDir            As String
 Dim colDir               As New Collection
 Dim varDateipfade        As Variant
 
 On Error GoTo Err_FTPDateipfadeAuslesen
 
 ' ggf. Slash am Pfadanfang hinzufügen
 If Not Left(Ordnerpfad, 1) = "/" Then
   Ordnerpfad = "/" & Ordnerpfad
 End If
 
 ' ggf. Slash am Pfadende hinzufügen
 If Not Right(Ordnerpfad, 1) = "/" Then
   Ordnerpfad = Ordnerpfad & "/"
 End If
 
 ' Ordnerpfad in Collection einlesen
 colDir.Add Ordnerpfad
 
 ' Collection durchlaufen
 Do While colDir.Count > 0
 
   ' Ersten (obersten) Eintrag der Collection auslesen
   strAktDir = colDir.Item(1)
 
   ' Eintrag dann löschen
   colDir.Remove 1
 
   j = j + 1
 
   ' Zusatzcode ab dem zweiten Durchlauf der Collection-Schleife
   If j > 1 Then
 
     ' Access-Anwendung bei längerer Laufzeit des Codes aktiv halten
     DoEvents
 
     ' Nächstes Unterverzeichnis als aktuelles Verzeichnis setzen
     lngUnterverzeichnis = FtpSetCurrentDirectory(hConnection, strAktDir)
 
     ' Wenn die Verbindung zum Unterverzeichnis nicht herstellbar ist
     If lngUnterverzeichnis = 0 Then
       MsgBox "Fehler beim Zugriff auf das Unterverzeichnis '" & strAktDir & "'!"
       ' Dateisuche abbrechen
       Resume Exit_FTPDateipfadeAuslesen
     End If
 
   End If
 
   i = 0
 
   ' Alle Dateien im aktuell zu prüfenden Unterverzeichnis suchen
   Do
 
     ' Puffer erzeugen
     pData.cFileName = String$(MAX_PATH, 0)
 
     ' Beim ersten Durchlauf der Dateisuche im aktuellen Verzeichnis
     If i = 0 Then
 
       ' Falls Handle hFind geöffnet
       If hFind Then
        ' Handle schließen
        InternetCloseHandle hFind
       End If
 
       ' Erste Datei suchen
       hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
 
       ' Wenn keine erste Datei gefunden wird, ist das Unterverzeichnis leer
       If hFind = 0 Then
         ' Abbruch der Unterverzeichnisprüfung
         Exit Do
       End If
 
     ' Beim jedem weiteren Durchlauf des Verzeichnisses
     Else
 
       ' Nächste Datei suchen
       lngfindnext = InternetFindNextFile(hFind, pData)
 
       ' wenn keine nächste Datei gefunden wird, gibt es keine weitere Datei mehr
       If lngfindnext = 0 Then
         ' Abbruch der Unterverzeichnisprüfung
         Exit Do
       End If
 
     End If
 
     ' Dateinamen auslesen
     strDateiname = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar) - 1)
 
     ' Wenn der Dateiname ein Verzeichnis ist
     If pData.dwFileAttributes = vbDirectory Then
 
       ' Pfad und Namen des gefundenen Verzeichnisses in die Collection einlesen
       If MitUnterordner = True Then
         colDir.Add strAktDir & strDateiname & "/"
       End If
 
     ' Wenn der Dateiname eine Datei ist
     Else
 
       ' Variant-Variable in Array umwandeln
       If Not IsArray(varDateipfade) Then
         varDateipfade = Array()
       End If
 
       ' Pfad und Namen der gefundenen Datei in das Array einlesen
       ReDim Preserve varDateipfade(k)
       varDateipfade(k) = strAktDir & strDateiname
       k = k + 1
 
     End If
 
     i = i + 1
 
   Loop
 
 Loop
 
 ' Rückgabewert setzen
 FTPDateipfadeAuslesen = varDateipfade
 
Exit_FTPDateipfadeAuslesen:
 
 ' Handle hFind schließen
 InternetCloseHandle hFind
 
 Exit Function
 
Err_FTPDateipfadeAuslesen:
 
 ' Standard-Fehlermeldung
 MsgBox "Laufzeitfehler '" & err.Number & "':" & vbCrLf & vbLf & err.Description
 
 Resume Exit_FTPDateipfadeAuslesen
 
End Function
 
 
Public Sub FTPLogout()
 
   ' hConnection schließen
   InternetCloseHandle hConnection
 
   ' hOpen schließen
   InternetCloseHandle hOpen
 
End Sub

Aufruf

   Dim strServer                     As String
   Dim strBenutzer                   As String
   Dim strPasswort                   As String
   Dim strRelativerPfadRemoteordner  As String
   Dim varElement                    As Variant
   Dim varDateipfade                 As Variant
 
   strServer = "www.meine-domain.de"
   strBenutzer = "12345678"
   strPasswort = "geheim"
   strRelativerPfadRemoteordner = "htdocs/meinunterordner/meinunterunterordner"
 
   ' Wenn Login erfolgreich
   If FTPLogin(strServer, strBenutzer, strPasswort, strRelativerPfadRemoteordner) Then
 
      ' Dateipfade in Array einlesen, inklusive Dateien aus den Unterordnern (True)
      varDateipfade = FTPDateipfadeAuslesen(strRelativerPfadRemoteordner, True)
 
      ' Wenn Dateien gefunden wurden
      If IsArray(varDateipfade) Then
 
        ' Gefundene Dateipfade im Direktfenster auflisten
        For Each varElement In varDateipfade
           Debug.Print varElement
        Next
 
      End If
 
   End If
 
   ' Logout
   Call FTPLogout


Wikilinks