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.

'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
 
'FtpDeleteFile (Internet-Datei löschen)
Private Declare Function FtpDeleteFile Lib "wininet.dll" _
   Alias "FtpDeleteFileA" ( _
   ByVal hFtpSession As Long, _
   ByVal lpszFileName As String) 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(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)
 
   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 FTPAlleDateienLoeschen() As Boolean
 
   ' Alle Dateien in einem Internet-Ordner löschen, Unterordner werden nicht gelöscht
 
   Dim pData             As WIN32_FIND_DATA
   Dim lngfindnext       As Long
   Dim strDateiname      As String
   Dim strOrdnerPfad     As String
   Dim lngGeloescht      As Long
   Dim bolIstOrdner      As Boolean
   Dim bolNichtGeloescht As Boolean
 
 
   On Error GoTo Err_FTPAlleDateienLoeschen
 
   '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, vbNullChar) - 1)
   lngGeloescht = FtpDeleteFile(hConnection, strDateiname)
 
   'wenn das Löschen einer Datei (kein Verzeichnis) fehlgeschlagen ist
   If lngGeloescht = 0 And pData.dwFileAttributes <> 16 Then
      bolNichtGeloescht = 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
 
      'nächsten Dateinamen löschen
      strDateiname = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar) - 1)
      lngGeloescht = FtpDeleteFile(hConnection, strDateiname)
 
      If lngGeloescht = 0 And pData.dwFileAttributes <> 16 Then
         bolNichtGeloescht = True
      End If
 
   Loop
 
   'Rückgabewert setzen
   FTPAlleDateienLoeschen = Not bolNichtGeloescht
 
Exit_FTPAlleDateienLoeschen:
 
   'wenn hFind geöffnet, schließen
   If hFind Then InternetCloseHandle hFind
   Exit Function
 
Err_FTPAlleDateienLoeschen:
 
   'Fehlermeldung
   MsgBox "Laufzeitfehler '" & Err.Number & "':" & vbCrLf & vbLf & Err.Description
   Resume Exit_FTPAlleDateienLoeschen
 
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 strRelRemotePath As String
   Dim varElement       As Variant
   Dim strarr()         As String
 
   strServer = "www.meine-domain.de"
   strBenutzer = "12345678"
   strPasswort = "geheim"
   strRelRemotePath = "htdocs/einunterordner/einunterunterordner"
 
   'Login
   If FTPLogin(strServer, strBenutzer, strPasswort, strRelRemotePath) = 0 Then
      Call FTPLogout
      Exit Sub
   End If
 
   'Dateien löschen
   If FTPAlleDateienLöschen() Then
      MsgBox "Alle Dateien wurden gelöscht."
   Else
      MsgBox "Mindestens eine Datei wurde nicht gelöscht."
   End If
 
   'Logout
   Call FTPLogout


Wikilinks


Wiki warning.png

Achtung:

Bitte die Funktion FTPAlleDateienLoeschen() mit größter Sorgfalt verwenden. Bei versehentlicher Wahl des falschen Verzeichnisses können gravierende Datenverluste entstehen!


Der Code ist ab Access 2000 lauffähig.