VBA Tipp: Alle Dateien in einem Internetverzeichnis löschen (FTP)

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

  • Ich möchte alle Dateien in einem Internetverzeichnis löschen. Unterverzeichnisse werden nicht gelöscht.
  • Die Löschung geschieht ohne Vorwarnung, und ist nicht rückgängig zu machen!
  • 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.
'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
 
'FtpDeleteFile (Internet-Datei löschen)
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" ( _
                         ByVal hFtpSession As Long, _
                         ByVal lpszFileName As String _
                         ) As Boolean
 
'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 FTPAlleDateienLöschen() As Boolean
 
 ' Alle Dateien in einem Internet-Ordner löschen, Unterordner werden nicht gelöscht
 'Quelle: http://www.dbwiki.net/
 
 On Error GoTo Err_FTPAlleDateienLöschen
 
 Dim pData As WIN32_FIND_DATA
 Dim lngfindnext As Long
 Dim strDateiname As String
 Dim strOrdnerPfad As String
 Dim lngGelöscht As Long
 Dim bolIstOrdner As Boolean
 Dim bolnichtgelöscht As Boolean
 
 'Dateien löschen
 
 'Puffer erzeugen
 pData.cFileName = String(MAX_PATH, 0)
 
 'erste Datei suchen
 hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
 
 'wenn keine Datei gefunden
 If hFind = 0 Then
   'Fehlermeldung
'   MsgBox "Das Internetverzeichnis ist leer!"
   Exit Function
 End If
 
 'ersten Dateinamen löschen
 strDateiname = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
 lngGelöscht = FtpDeleteFile(hConnection, strDateiname)
 
 'wenn das Löschen einer Datei (kein Verzeichnis) fehlgeschlagen ist
 If lngGelöscht = 0 And pData.dwFileAttributes <> 16 Then
   bolnichtgelöscht = True
 End If
 
 Do
   'Puffer erzeuegn
   pData.cFileName = String(MAX_PATH, 0)
 
   'nächste Datei suchen
   lngfindnext = InternetFindNextFile(hFind, pData)
 
   'wenn keine nächste Datei gefunden, Abbruch
   If lngfindnext = 0 Then
     Exit Do
   End If
 
   'nächsten Dateinamen löschen
   strDateiname = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
   lngGelöscht = FtpDeleteFile(hConnection, strDateiname)
 
   If lngGelöscht = 0 And pData.dwFileAttributes <> 16 Then
     bolnichtgelöscht = True
   End If
 
 Loop
 
 'Rückgabewert setzen
 If bolnichtgelöscht = False Then
   FTPAlleDateienLöschen = True
 Else
   FTPAlleDateienLöschen = False
 End If
 
Exit_FTPAlleDateienLöschen:
 
 'wenn hFind geöffnet, schließen
 If hFind Then
   InternetCloseHandle hFind
 End If
 Exit Function
 
Err_FTPAlleDateienLöschen:
 
 'Fehlermeldung
 MsgBox "Laufzeitfehler '" & Err.Number & "':" & vbCrLf & vbLf & Err.Description
 Resume Exit_FTPAlleDateienLöschen
 
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
 
 'Dateien löschen
 If FTPAlleDateienLöschen() = True Then
   MsgBox "Alle Dateien wurden gelöscht."
 Else
   MsgBox "Mindestens eine Datei wurde nicht gelöscht."
 End If
 
 'Logout
 Call FTPLogout


Wiki-Links


Wiki warning.png Achtung: Bitte die Funktion "FTPAlleDateienLöschen" mit größter Sorgfalt verwenden. Bei versehentlicher Wahl des falschen Verzeichnisses können gravierende Datenverluste entstehen!


Der Code ist ab Access 2000 lauffähig.