VBA Tipp: Größe und Anzahl aller Dateien aus einem Internetverzeichnis auslesen

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

  • Ich möchte die Größe und optional die Anzahl aller Dateien aus einem Internetverzeichnis auslesen.
  • Optional kann ich alle Unterordner in die Suche mit einbeziehen.
  • Bitte Beachten: Das Auslesen dauert ca. 10 ms pro Datei, d.h. bei 1000 Dateien läuft der Code ca. 10 Sekunden, bis das Ergebnis angezeigt wird.
  • 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 allgemeinen (globalen) Modul hinterlegt werden.

'Quelle: http://www.dbwiki.net/
 
'Variablen für die Internetverbindung
Private hOpen       As Long
Private hConnection As Long
Private hFind       As Long
 
'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
 
 
Public Function FTPLogin(Server As String, _
                         Benutzer As String, _
                         Passwort As String, _
                         Optional RelativerOrdnerpfad As String, _
                         Optional ByVal OhneFehlermeldung As Boolean) As Long
 
   'Internetverbindung herstellen
 
   hOpen = InternetOpen("MeineVerbindung", INTERNET_OPEN_TYPE_PRECONFIG, _
                        vbNullString, vbNullString, 0)
 
   'Wenn Internetverbindung nicht herstellbar
   If hOpen = 0 Then
      'Fehlermeldung
      If OhneFehlermeldung = False Then
         MsgBox "Fehler beim Aufbau der Internetverbindung!"
         Exit Function
      End If
   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
   End If
   '----------------------------------------------------------------------------------
 
   'Holt das aktuelle Root-Verzeichnis
 
   Dim strRootpfad As String
   Dim lngRoot     As Long
 
   'Puffer für das aktuelle Verzeichnis
   strRootpfad = String$(MAX_PATH, 0)
 
   lngRoot = FtpGetCurrentDirectory(hConnection, strRootpfad, Len(strRootpfad))
 
   'wenn Verbindung zum Rootverzeichnis nicht herstellbar
   If lngRoot = 0 Then
      Call FTPLogout
      If OhneFehlermeldung = False Then
         MsgBox "Fehler beim Zugriff auf das Hauptverzeichnis !"
         Exit Function
      End If
   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 FTPDateigrößenAuslesen(ByVal Ordnerpfad As String, _
                                       Optional ByVal MitUnterordner As Boolean = False, _
                                       Optional ByRef Dateianzahl As Long _
                                       ) As Currency
 
 ' Alle Dateien in einem Internet-Ordner durchlaufen und Dateigrößen und optional Dateianzahl addieren
 ' Wenn das Argument "MitUnterordner" auf True gesetzt wird,
 ' werden zusätzlich alle Unterordner in die Suche mit einbezogen.
 
 Dim pData                As WIN32_FIND_DATA
 Dim lngfindnext          As Long
 Dim strDateiname         As String
 Dim curGesamtgröße       As Currency
 Dim i                    As Long
 Dim j                    As Long
 Dim lngUnterverzeichnis  As Long
 Dim strAktDir            As String
 Dim colDir               As New Collection
 
 On Error GoTo Err_FTPDateigrößenAuslesen
 
 'ggf. Slash am Pfadende hinzufügen, sonst Fehler. Slash am Pfadanfang ist egal.
 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 Eintrag auslesen
   strAktDir = colDir.Item(1)
 
   'und dann löschen
   colDir.Remove 1
 
   j = j + 1
 
   'Ab dem zweiten Durchlauf der Schleife
   If j > 1 Then
 
     'Access-Anwendung bei längerer Laufzeit des Codes aktiv halten
     DoEvents
 
     'Setzt das nächste Unterverzeichnis als aktuelles Verzeichnis
     lngUnterverzeichnis = FtpSetCurrentDirectory(hConnection, strAktDir)
 
     'Wenn Verbindung zum Unterverzeichnis nicht herstellbar
     If lngUnterverzeichnis = 0 Then
       MsgBox "Fehler beim Zugriff auf das Unterverzeichnis '" & strAktDir & "'!"
       Resume Exit_FTPDateigrößenAuslesen
     End If
 
   End If
 
   i = 0
 
   'Dateien suchen
   Do
 
     i = i + 1
 
     'Puffer erzeugen
     pData.cFileName = String$(MAX_PATH, 0)
 
     If i = 1 Then
 
       'wenn hFind geöffnet, schließen
       If hFind Then
         InternetCloseHandle hFind
       End If
 
       'erste Datei suchen
       hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
 
       'wenn keine Datei gefunden
       If hFind = 0 Then
         GoTo Exit_FTPDateigrößenAuslesen
       End If
 
     Else
 
       'nächste Datei suchen
       lngfindnext = InternetFindNextFile(hFind, pData)
 
       'wenn keine nächste Datei gefunden, Abbruch
       If lngfindnext = 0 Then
         Exit Do
       End If
 
     End If
 
     'Dateinamen auslesen
     strDateiname = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar) - 1)
 
     'Wenn Verzeichnis
     If pData.dwFileAttributes = vbDirectory Then
 
       'Pfad des gefundenen Unterordners in Collection einlesen
       If MitUnterordner = True Then
         colDir.Add strAktDir & strDateiname & "/"
       End If
 
       'Dateigröße addieren
       curGesamtgröße = curGesamtgröße + pData.nFileSizeLow
 
     'Wenn Datei, Größe und Anzahl addieren
     Else
 
       'Dateigröße addieren
       curGesamtgröße = curGesamtgröße + pData.nFileSizeLow
 
       'Dateianzahl addieren
       Dateianzahl = Dateianzahl + 1
 
     End If
 
   Loop
 
 Loop
 
 'Rückgabewert
 FTPDateigrößenAuslesen = curGesamtgröße
 
Exit_FTPDateigrößenAuslesen:
 
 'hFind schließen
 InternetCloseHandle hFind
 
 Exit Function
 
Err_FTPDateigrößenAuslesen:
 
 'Fehlermeldung
 MsgBox "Laufzeitfehler '" & Err.Number & "':" & vbCrLf & vbLf & Err.Description
 
 Resume Exit_FTPDateigrößenAuslesen
 
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 lngDateianzahl                As Long
 Dim curRet                        As Currency
 
 strServer = "www.meine-domain.de"
 strBenutzer = "12345678"
 strPasswort = "geheim"
 strRelativerPfadRemoteordner = "htdocs/meinunterordner/meinunterunterordner"
 
 'Wenn Login erfolgreich
 If FTPLogin(strServer, strBenutzer, strPasswort, strRelativerPfadRemoteordner) Then
 
   'Dateigrößen und Dateianzahl auslesen, Unterordner mit einbeziehen
   curRet = FTPDateigrößenAuslesen(strRelativerPfadRemoteordner, True, lngDateianzahl)
 
   'Bitte Beachten: Das Auslesen dauert ca. 10 ms pro Datei, d.h. bei 1000 Dateien
   'läuft der Code ca. 10 Sekunden, bis das Ergebnis angezeigt wird.
 
   'Ergebnis darstellen
   'in MB anzeigen
   If curRet >= 2 ^ 20 Then
     MsgBox "Größe: " & Format(Round(curRet / 1024 / 1024, 2), "#,###.## MB") & vbCrLf & _
            lngDateianzahl & " Dateien"
 
   'in KB anzeigen, auf volle KB aufrunden
   Else
     MsgBox "Größe: " & Format(curRet \ 1024 + Abs(CBool(curRet Mod 1024)), "# KB") & vbCrLf & _
            lngDateianzahl & " Dateien"
   End If
 
 End If
 
 'Logout
 Call FTPLogout