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

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

  • Ich möchte die Namen aller Dateien (und ggf. auch aller Unterverzeichnisse) aus einem Internetverzeichnis auslesen und auflisten.
  • Der Zugang zu dem 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 globalen Modul hinterlegt werden.


Die Funktion FTPDateinamenAuslesen() gibt ein Array mit allen Dateinamen zurück.

'Quelle: http://www.dbwiki.net/
 
Option Explicit
 
'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
 
'InternetOpen (Internet öffnen)
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
Private Const INTERNET_OPEN_TYPE_DIRECT    As Long = 1
 
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
 
'FtpGetCurrentDirectory (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
 
'FtpSetCurrentDirectory (zum FTP-Unterverzeichnis wechseln)
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" _
   Alias "FtpSetCurrentDirectoryA" ( _
   ByVal hConnect As Long, _
   ByVal lpszDirectory As String) As Long
 
'FtpFindFirstFile (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
 
'InternetFindNextFile (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
 
'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
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
 
   '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
 
   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
      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
   '----------------------------------------------------------------------------------
 
   'holt das aktuelle Verzeichnis
 
   Dim strOrgPfad As String
   Dim lngRoot    As Long
 
   'einen Puffer erzeugen, um das Originalverzeichnis zu speichern
   strOrgPfad = String(MAX_PATH, 0)
 
   lngRoot = FtpGetCurrentDirectory(hConnection, strOrgPfad, Len(strOrgPfad))
 
   'wenn Verbindung zum Rootverzeichnis nicht herstellbar
   If lngRoot = 0 Then
      If OhneFehlermeldung = False Then _
         MsgBox "Fehler beim Zugriff auf das Hauptverzeichnis!"
      Exit Function
   End If
   '----------------------------------------------------------------------------------
 
   'Setzt das aktuelle Verzeichnis auf den Unterordner
 
   Dim lngUnterverzeichnis As Long
 
   '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
      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 FTPDateinamenAuslesen(Optional ByVal UnterordnerAnzeigen As Boolean = False _
                                     ) As Variant
 
 'Gibt ein Array mit allen Dateinamen eines Verzeichnisses zurück
 
 'Argument "UnterordnerAnzeigen":
 'Wenn True, werden auch die Namen der Unterverzeichnisse mit aufgelistet.
 
 Dim pData                         As WIN32_FIND_DATA
 Dim hFind                         As Long
 Dim lret                          As Long
 Dim strDateinamen()               As String
 Dim i                             As Long
 Dim strRelativerPfadRemoteordner  As String
 
 'Anfangswert als Rückgabewert setzen
 FTPDateinamenAuslesen = strDateinamen()
 
 'Puffer erzeugen
 pData.cFileName = String(MAX_PATH, 0)
 
 'erste Datei suchen
 hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
 
 'wenn keine Datei gefunden, Abbruch
 If hFind = 0 Then
   Exit Function
 End If
 
 'Ersten Dateinamen in Array einlesen
 If UnterordnerAnzeigen = True Or Not pData.dwFileAttributes = vbDirectory Then
 
   'Array dimensionieren
   ReDim Preserve strDateinamen(i)
 
   strDateinamen(i) = Left(pData.cFileName, _
                      InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
 End If
 
 'Weitere Dateinamen suchen
 Do
   'Puffer erzeuegn
   pData.cFileName = String(MAX_PATH, 0)
 
   'nächste Datei suchen
   lret = InternetFindNextFile(hFind, pData)
 
   'wenn keine nächste Datei gefunden, Abbruch
   If lret = 0 Then
     Exit Do
   End If
 
   'weiteren Dateinamen in Array einlesen
   If UnterordnerAnzeigen = True Or Not pData.dwFileAttributes = vbDirectory Then
 
     i = i + 1
 
     'Array dimensionieren
     ReDim Preserve strDateinamen(i)
 
     strDateinamen(i) = Left(pData.cFileName, _
                        InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
 
   End If
 
 Loop
 
 'hFind schließen
 InternetCloseHandle hFind
 
 'Rückgabewert setzen
 FTPDateinamenAuslesen = strDateinamen()
 
End Function
 
 
Public Sub FTPLogout()
 
   'hConnection schließen
   InternetCloseHandle hConnection
 
   'hOpen schließen
   InternetCloseHandle hOpen
 
End Sub

Aufruf

Die unten verwendete Funktion IstDimensioniert() ist im DBWiki zu finden.

   Dim strServer                     As String
   Dim strBenutzer                   As String
   Dim strPasswort                   As String
   Dim strRelativerPfadRemoteordner  As String
   Dim varElement                    As Variant
   Dim strDateinamen()               As String
 
   strServer = "www.meine-domain.de"
   strBenutzer = "12345678"
   strPasswort = "geheim"
   strRelativerPfadRemoteordner = "htdocs/meinunterordner/meinunterunterordner"
 
   'Login
   If FTPLogin(strServer, strBenutzer, strPasswort, strRelativerPfadRemoteordner) Then
 
      'Dateinamen ohne Unterordnernamen in Array einlesen
      strDateinamen = FTPDateinamenAuslesen(True)
 
      'wenn das Array dimensioniert ist (IstDimensioniert() ist eine Funktion aus dem DBWiki)
      If IstDimensioniert(strDateinamen) Then
 
        'Dateinamen im Direktfenster auflisten
        For Each varElement In strDateinamen
           Debug.Print varElement
        Next
 
      End If
 
   End If
 
   'Logout
   Call FTPLogout


Wikilinks