Untitled

Dateiliste eines FTP-Servers

Es wird die Dateiliste eines FTP-Servers mitsamt seinen Unterverzeichnissen erstellt. Als Informationen werden der Dateiname, der Pfad, die Dateigröße und die letzte Änderung geliefert.

Beispieldatei (filelistinet.zip 27 KB)

'########################################################
'# In ein Modul
'########################################################

Option Explicit
Private Declare Function InternetConnect Lib _
    "wininet.dll" Alias "InternetConnectA" _
    (ByVal hInternetSession 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
Private Declare Function FtpFindFirstFile Lib _
    "wininet.dll" Alias "FtpFindFirstFileA" _
    (ByVal hFtpSession As Long, _
    ByVal lpszSearchFile As String, _
    lpFindFileData As WIN32_FIND_DATA, _
    ByVal dwFlags As Long, _
    ByVal dwContent As Long) _
    As Long
Private Declare Function InternetFindNextFile Lib _
    "wininet.dll" Alias "InternetFindNextFileA" _
    (ByVal hFind As Long, _
    lpvFindData As WIN32_FIND_DATA) _
    As Long
Private Declare Function InternetOpen Lib "wininet" _
    Alias "InternetOpenA" _
    (ByVal sAgent As String, _
    ByVal lAccessType As Long, _
    ByVal sProxyName As String, _
    ByVal sProxyBypass As String, _
    ByVal lFlags As Long) _
    As Long
Private Declare Function InternetCloseHandle Lib "wininet" _
    (ByVal hInet As Long) _
    As Integer
Private Declare Function FileTimeToSystemTime Lib "kernel32" _
    (lpFileTime As FILETIME, _
    lpSystemTime As SYSTEMTIME) _
    As Long
Private Const PassiveConnection As Boolean = True
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const strMeinAgent = "XYZ"
Private Const MAX_PATH = 260
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

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

Private Type SYSTEMTIME
        wYear As Integer
        wMonth As Integer
        wDayOfWeek As Integer
        wDay As Integer
        wHour As Integer
        wMinute As Integer
        wSecond As Integer
        wMilliseconds As Integer
End Type

Public Sub DateilisteErstellen()
Dim Dateiliste, i As Long, k As Long
Dim Server As String, Username As String, Passwort As String, Anfangspfad As String
Dim AnzahlDateien As Long
Dim Zielbereich(1 To 5), Überschrift
Dim lngInetOpen As Long, lngConnection As Long
Dim Länge As Long, dummy As String
Dim MyFile As WIN32_FIND_DATA
On Error GoTo fehlerbehandlung
Server = "ftp.info.uni-karlsruhe.de"
Username = "ANONYMOUS"
Passwort = "a@2"
Anfangspfad = "/"
'Internet-Handle holen
lngInetOpen = InternetOpen(vbNullString, _
    INTERNET_OPEN_TYPE_DIRECT, _
    strMeinAgent, vbNullString, 0)
'Session-Handle holen
lngConnection = InternetConnect( _
    lngInetOpen, Server, _
    INTERNET_DEFAULT_FTP_PORT, _
    Username, Passwort, _
    INTERNET_SERVICE_FTP, _
    INTERNET_FLAG_PASSIVE, 0)
'Überprüfen, ob Verbindung hergestellt
If lngConnection <> 0 Then
    dummy = String(MAX_PATH, 0)
    Länge = Len(dummy)
    With Sheets(1)
        .Range("A6:IV65535").Delete
        Überschrift = Array("Datei", "Pfad", _
            "Kompletter Pfad", "Letzter Schreibzugriff", _
            "Größe")
        For k = 1 To 5
            .Cells(5, k) = Überschrift(k - 1)
        Next
        'Suche beginnen
        AnzahlDateien = DurchlaufePfad( _
            Anfangspfad, Dateiliste, lngConnection)
        Application.ScreenUpdating = False
        'Gefundene Dateien eintragen
        For i = 1 To AnzahlDateien
            For k = 1 To 5
                Zielbereich(k) = Dateiliste(k, i)
            Next
            .Range(.Cells(i + 5, 1), .Cells(i + 5, 5)) _
            = Zielbereich
        Next
    End With
End If
fehlerbehandlung:
InternetCloseHandle lngConnection
InternetCloseHandle lngInetOpen
Application.ScreenUpdating = True
End Sub

Private Function DurchlaufePfad( _
    ByVal Pfadname As String, _
    Dateiliste, MyHandle As Long, _
    Optional Dateiindex As Long) _
    As Long
Dim Suchhandle As Long, Rückgabewert1 As Long
Dim dummy As String, Suchkriterium As String
Dim Filedaten As WIN32_FIND_DATA, zeile As Long
Dim Unterverzeichnisse As New Collection
Dim Verzeichnis As Variant
If Dateiindex = 0 Then Dateiindex = 1
'Array erzeugen, falls noch nicht vorhanden
Select Case TypeName(Dateiliste)
    Case "Variant()"
        If UBound(Dateiliste, 1) <> 5 Then
            ReDim Dateiliste(1 To 5, 1 To 10000)
        End If
    Case "Empty"
        ReDim Dateiliste(1 To 5, 1 To 10000)
    Case Else
        Exit Function
End Select
If Right$(Pfadname, 1) = "/" Then
    Suchkriterium = Pfadname & "*"
Else
    Suchkriterium = Pfadname & "/*"
End If
zeile = Dateiindex
With Filedaten
    .cFileName = String(260, Chr(0))
    'Erste Datei/Verzeichnis suchen
    Suchhandle = FtpFindFirstFile(MyHandle, _
        Suchkriterium, Filedaten, 0, 0)
    Rückgabewert1 = Suchhandle
    Do While Rückgabewert1 <> 0
        'Dateiname zurechtstutzen
        .cFileName = Left(.cFileName, _
            InStr(1, .cFileName, Chr(0)) - 1)
        If (Trim(.cFileName) <> ".") And _
            (Trim(.cFileName) <> "..") Then
            If .dwFileAttributes And _
                FILE_ATTRIBUTE_DIRECTORY Then
                'Unterverzeichnis gefunden,
                'Zwischenspeichern.
                If Right(Pfadname, 1) = "/" Then _
                    dummy = "" Else dummy = "/"
                Unterverzeichnisse.Add Pfadname & dummy & _
                    Trim(.cFileName), "P" & zeile
            End If
            'wenn mehr Dateien gefunden wurden, als
            'Array Platz hat
            If zeile = UBound(Dateiliste, 2) Then _
                ReDim Preserve Dateiliste(1 To 8, _
                1 To zeile + 1000)
            'Das Array mit Daten füttern
            Dateiliste(1, zeile) = Trim(.cFileName)
            Dateiliste(2, zeile) = Pfadname
            If Right(Pfadname, 1) = "/" Then _
                dummy = "" Else dummy = "/"
            Dateiliste(3, zeile) = Pfadname & _
                dummy & Dateiliste(1, zeile)
            Dateiliste(4, zeile) = Zeitumwandlung( _
                .ftLastWriteTime)
            Dateiliste(5, zeile) = Filedaten.nFileSizeLow
            zeile = zeile + 1
        End If
        .cFileName = String(260, Chr(0))
        Rückgabewert1 = InternetFindNextFile( _
            Suchhandle, Filedaten)
    Loop
End With
For Each Verzeichnis In Unterverzeichnisse
    'Die Unterverzeichnisse abfragen,
    'aber vorher Suchhandle schließen
    InternetCloseHandle Suchhandle
    zeile = DurchlaufePfad(Verzeichnis, _
        Dateiliste, MyHandle, zeile)
Next
'Suchhandle schließen
InternetCloseHandle Suchhandle
'Anzahl Dateien zurück
DurchlaufePfad = zeile
End Function

Private Function Zeitumwandlung(Filezeit As FILETIME)
Dim S_Zeit As SYSTEMTIME
FileTimeToSystemTime Filezeit, S_Zeit
If S_Zeit.wYear >= 1900 Then
    Zeitumwandlung = CDbl(DateSerial(S_Zeit.wYear, _
    S_Zeit.wMonth, S_Zeit.wDay) _
    + TimeSerial(S_Zeit.wHour, S_Zeit.wMinute, S_Zeit.wSecond))
Else
    Zeitumwandlung = ""
End If
End Function