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 strOrdnerPfad       As String
   Dim lngUnterverzeichnis As Long
 
   'ggf. Slash am Ende hinzufügen, sonst Fehler
   'Am Anfang ist egal, ob Slash oder nicht
   If Right$(RelativerOrdnerpfad, 1) = "/" Then
      strOrdnerPfad = RelativerOrdnerpfad
   Else
      strOrdnerPfad = RelativerOrdnerpfad & "/"
   End If
 
   lngUnterverzeichnis = FtpSetCurrentDirectory(hConnection, strOrdnerPfad)
 
   'wenn Verbindung zum Unterverzeichnis nicht herstellbar
   If lngUnterverzeichnis = 0 Then
      Call FTPLogout
      If OhneFehlermeldung = False Then _
         MsgBox "Fehler beim Zugriff auf das Unterverzeichnis!"
      Exit Function
   End If
   '----------------------------------------------------------------------------------
 
   'Rückgabewert
   FTPLogin = lngUnterverzeichnis
 
End Function
 
 
Public Function FTPDateinamenAuslesen(Optional ByVal UnterordnerAnzeigen As Boolean) As String()
 
   'Gibt ein Array mit allen Dateinamen eines Verzeichnisses zurück
 
   Dim pData           As WIN32_FIND_DATA
   Dim hFind           As Long
   Dim lret            As Long
   Dim i               As Long
   Dim strDateinamen() As String
 
   'Initialisierungsvorgang des Arrays, wichtig
   'dem Array Platz 0 zuweisen
   ReDim strDateinamen(0)
 
   'Rückgabewert der Funktion, Grundwert setzen, wichtig
   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
 
   'ersten Dateinamen in Array einlesen, keine Verzeichnisse
   If UnterordnerAnzeigen Or Not pData.dwFileAttributes = 16 Then
      strDateinamen(i) = Left$(pData.cFileName, _
                               InStr(1, pData.cFileName, vbNullChar) - 1)
   End If
 
   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
 
      i = i + 1
 
      'dem Array den nächsten Platz zuweisen
      ReDim Preserve strDateinamen(i)
      'weiteren Dateinamen in Array einlesen, keine Verzeichnisse
      If UnterordnerAnzeigen Or Not pData.dwFileAttributes = 16 Then
         strDateinamen(i) = Left$(pData.cFileName, _
                                  InStr(1, pData.cFileName, vbNullChar) - 1)
      End If
 
   Loop
 
   'wenn hFind geöffnet, schließen
   If hFind Then InternetCloseHandle hFind
 
   'Rückgabewert setzen
   FTPDateinamenAuslesen = strDateinamen()
 
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
 
End Sub

Aufruf

   Dim strServer As String
   Dim strBenutzer As String
   Dim strPasswort As String
   Dim strRelativerPfadRemoteordner As String
   Dim varElement As Variant
   Dim strarr() As String
 
   strServer = "www.meine-domain.de"
   strBenutzer = "12345678"
   strPasswort = "geheim"
   strRelativerPfadRemoteordner = "htdocs/meinunterordner/meinunterunterordner"
 
   'Login
   If FTPLogin(strServer, strBenutzer, strPasswort, strRelativerPfadRemoteordner) = 0 Then
      Call FTPLogout
      Exit Sub
   End If
 
   'Dateinamen in Array einlesen, ohne Unterordner
    strarr = FTPDateinamenAuslesen
 
   'Dateinamen im Direktfenster auflisten
   For Each varElement In strarr
      Debug.Print varElement
   Next
 
   'Logout
   Call FTPLogout


Wikilinks

Der Code ist ab Access 2000 lauffähig.