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 den Dateinamen zurück.
'Variablen für die Internetverbindung
Private hOpen As Long
Private hConnection As Long
Private hFind As Long
 
'Konstanten
 
'für FtpFindFirstFile
'für Private Type WIN32_FIND_DATA
Private Const MAX_PATH = 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 = 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 = 21      'Standardwert für FTP-Server (nServerPort)
Private Const INTERNET_INVALID_PORT_NUMBER = 0    'alternativ für nServerPort
Private Const INTERNET_SERVICE_FTP = 1            'lService
Private Const INTERNET_FLAG_PASSIVE = &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 Boolean
 
'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 Integer
 
 
Public Function FTPLogin(ByVal Server As String, _
                         ByVal Benutzer As String, _
                         ByVal Passwort As String, _
                         Optional ByVal RelativerOrdnerpfad As String = vbNullString, _
                         Optional ByVal FehlermeldungAus As Boolean = False _
                         ) As Long
 
 'Internetverbindung herstellen
 
 hOpen = InternetOpen("MeineVerbindung", INTERNET_OPEN_TYPE_PRECONFIG, _
                          vbNullString, vbNullString, 0)
 
 If hOpen = 0 Then
   'Fehlermeldung
   If FehlermeldungAus = False Then
     MsgBox "Fehler beim Aufbau der Internetverbindung!"
   End If
   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
 '----------------------------------------------------------------------------------
 
 '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
   'Fehlermeldung
   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
   'Fehlermeldung
   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 = False _
                ) As Variant
 
 'Gibt ein Array mit allen Dateinamen eines Verzeichnisses zurück
 'Quelle: http://www.dbwiki.net/
 
 Dim pData As WIN32_FIND_DATA
 Dim hFind As Long
 Dim lret As Long
 Dim strDateinamen() As String
 Dim i As Integer
 Dim strRelativerPfadRemoteordner As String
 
 'Initialisierungsvorgang des Arrays, wichtig
 i = 0 'Anfangswert
 'dem Array Platz 0 zuweisen
 ReDim Preserve strDateinamen(i)
 
 '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
 End If
 
 'ersten Dateinamen in Array einlesen, keine Verzeichnisse
 If UnterordnerAnzeigen = True Or Not pData.dwFileAttributes = 16 Then
   strDateinamen(i) = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 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
   End If
 
   i = i + 1
 
   'dem Array den nächsten Platz zuweisen
   ReDim Preserve strDateinamen(i)
   'weiteren Dateinamen in Array einlesen, keine Verzeichnisse
   If UnterordnerAnzeigen = True Or Not pData.dwFileAttributes = 16 Then
     strDateinamen(i) = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
   End If
 
 Loop
 
 'wenn hFind geöffnet, schließen
 If hFind Then
   InternetCloseHandle hFind
 End If
 
 'Rückgabewert setzen
 FTPDateinamenAuslesen = strDateinamen()
 
End Function
 
 
Public Sub FTPLogout()
 
 'wenn hConnection geöffnet, schließen
 If hConnection Then
   InternetCloseHandle hConnection
 End If
 
 'wenn hOpen geöffnet, schließen
 If hOpen Then
   InternetCloseHandle hOpen
 End If
 
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


Wiki-Links


Der Code ist ab Access 2000 lauffähig.