Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1152to1156
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

PDF Dateien löschen

PDF Dateien löschen
Valeri
Hallo Forum,
in meiner Excelliste habe ich eine Spalte A in der Dokumentennummern mit Revision stehen, in der Spalte B habe ich eine Formel die mir einen Hyperlink erzeugt der zu PDF Dateien mit der Nummer aus Spalte A führt. Wenn sich eine Revision ändert dann kommt auch einen neue PDF Datei mit der neuen Revision in den Zielordner. Ich möchte jezt das ich per VBA alle PDF Dateien die nicht in der Spalte A auftauchen im Zielordner löschen.
Wie geht das?
mfg Valeri
AW: PDF Dateien löschen
27.04.2010 09:38:07
Tino
Hallo,
kannst mal testen.
Achtung:
Teste den Code erst an einem Beispiel, gelöschte Dateien lassen sich nicht ohne Aufwand wiederherstellen.

kommt als Code in Modul1
Option Explicit 
 
Sub KillPDFFiles() 
Dim sfaPtr As Long 
Dim nCount As Long 
Dim strFilesName As String 
 
'1. Parameter Optional Filter Standard = *; 
'2. Parameter Optional suche mit Unterordner Standard = False 
Call SucheDateien("*.pdf", False) 
 
GetSafeArrayPointer strDateien, sfaPtr 
 
If sfaPtr > 0 Then 
    For nCount = Lbound(strDateien) To Ubound(strDateien) 
        strFilesName = Right$(strDateien(nCount), Len(strDateien(nCount)) - InStrRev(strDateien(nCount), "\")) 
        If Not IsNumeric(Application.Match(strFilesName, Tabelle1.UsedRange.Columns(1), 0)) Then 
            Kill strDateien(nCount) 
        End If 
    Next nCount 
End If 
 
End Sub 
kommt als Code in Modul2
Option Explicit 
'******************************************************************************* 
'der größte Teil vom Code stammt von Nepumuk                                   * 
'******************************************************************************* 
 
Declare Sub GetSafeArrayPointer Lib "msvbvm60.dll" Alias "GetMem4" _
                    (pArray() As Any, sfaPtr As Long) 
 
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    lpFindFileData As WIN32_FIND_DATA) As Long 
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    lpFindFileData As WIN32_FIND_DATA) As Long 
Private Declare Function FindClose Lib "kernel32" ( _
    ByVal hFindFile As Long) As Long 
 
Private Enum FILE_ATTRIBUTE 
    FILE_ATTRIBUTE_READONLY = &H1 
    FILE_ATTRIBUTE_HIDDEN = &H2 
    FILE_ATTRIBUTE_SYSTEM = &H4 
    FILE_ATTRIBUTE_DIRECTORY = &H10 
    FILE_ATTRIBUTE_ARCHIVE = &H20 
    FILE_ATTRIBUTE_NORMAL = &H80 
    FILE_ATTRIBUTE_TEMPORARY = &H100 
End Enum 
 
Private Const INVALID_HANDLE_VALUE = -1& 
Private Const MAX_PATH = 260& 
 
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 Declare Function MoveWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long 
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long 
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long 
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    lpbi As InfoT) As Long 
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long 
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long 
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long 
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    wParam As Any, _
    lParam As Any) As Long 
 
Private Type InfoT 
    hwnd As Long 
    Root As Long 
    DisplayName As Long 
    Title As Long 
    Flags As Long 
    FName As Long 
    lParam As Long 
    Image As Long 
End Type 
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
Public Enum BIF_Flag 
    BIF_RETURNONLYFSDIRS = &H1 
    BIF_DONTGOBELOWDOMAIN = &H2 
    BIF_STATUSTEXT = &H4 
    BIF_RETURNFSANCESTORS = &H8 
    BIF_EDITBOX = &H10 
    BIF_VALIDATE = &H20 
    BIF_NEWDIALOGSTYLE = &H40 
    BIF_BROWSEINCLUDEURLS = &H80 
    BIF_BROWSEFORCOMPUTER = &H1000 
    BIF_BROWSEFORPRINTER = &H2000 
    BIF_BROWSEINCLUDEFILES = &H4000 
    BIF_SHAREABLE = &H8000 
End Enum 
 
Private Const SM_CXFULLSCREEN = &H10 
Private Const SM_CYFULLSCREEN = &H11 
 
Private Const BFFM_SETSELECTION = &H466 
Private Const BFFM_INITIALIZED = &H1 
 
Private s_BrowseInitDir As String 
Public strDateien() As String 
Public Function fncGetFolder( _
        Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
        Optional ByVal lFlag As BIF_Flag = BIF_RETURNONLYFSDIRS, _
        Optional ByVal sPath As String = "C:\") As String 
    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String 
    s_BrowseInitDir = sPath 
    With xl 
        .hwnd = FindWindow("XLMAIN", vbNullString) 
        .Root = 0 
        .Title = lstrcat(sMsg, "") 
        .Flags = lFlag 
        .FName = FuncCallback(AddressOf BrowseCallback) 
    End With 
    IDList = SHBrowseForFolder(xl) 
    If IDList <> 0 Then 
        FolderName = Space(256) 
        RVal = SHGetPathFromIDList(IDList, FolderName) 
        CoTaskMemFree (IDList) 
        FolderName = Trim$(FolderName) 
        FolderName = Left$(FolderName, Len(FolderName) - 1) 
    End If 
    fncGetFolder = FolderName 
End Function 
 
Private Function BrowseCallback( _
        ByVal hwnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long 
    If uMsg = BFFM_INITIALIZED Then 
        Call SendMessage(hwnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir) 
        Call CenterDialog(hwnd) 
    End If 
    BrowseCallback = 0 
End Function 
 
Private Function FuncCallback(ByVal nParam As Long) As Long 
    FuncCallback = nParam 
End Function 
 
Private Sub CenterDialog(ByVal hwnd As Long) 
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer 
    Dim DlgWidth As Integer, DlgHeight As Integer 
    GetWindowRect hwnd, WinRect 
    DlgWidth = WinRect.Right - WinRect.Left 
    DlgHeight = WinRect.Bottom - WinRect.Top 
    ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN) 
    ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN) 
    MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1 
End Sub 
 
Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String, _
        ByRef lngFilecount As Long, Optional Subfolder As Boolean = True) 
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String 
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD) 
    If lngSearch <> INVALID_HANDLE_VALUE Then 
        GetFilesInFolder strFolderPath, strSearch, lngFilecount 
        Do 
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then 
                strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1) 
                If Subfolder = False Then Exit Sub 'ohne Unterordner 
                If (strDirName <> ".") And (strDirName <> "..") Then _
                    FindFiles strFolderPath & strDirName & "\", strSearch, lngFilecount 
            End If 
        Loop While FindNextFile(lngSearch, WFD) 
        FindClose lngSearch 
    End If 
End Sub 
 
Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String, _
        ByRef lngFilecount As Long) 
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String 
    lngSearch = FindFirstFile(strFolderPath & strSearch, WFD) 
    If lngSearch <> INVALID_HANDLE_VALUE Then 
        Do 
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> _
                FILE_ATTRIBUTE_DIRECTORY Then 
                strFileName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1) 
                 Redim Preserve strDateien(lngFilecount) 
                    strDateien(lngFilecount) = strFolderPath & strFileName 
                    lngFilecount = lngFilecount + 1 
            End If 
        Loop While FindNextFile(lngSearch, WFD) 
        FindClose lngSearch 
    End If 
End Sub 
 Sub SucheDateien(Optional strSearch As String = "*", Optional Subfolder As Boolean = False) 
    Dim myFileSystemObject As Object, myDrive As Object 
    Dim lngFilecount As Long 
    Dim strFolder As String 
    Dim Pfad As String 
     
    strFolder = Trim$(fncGetFolder(sPath:="C:\")) 
    If strFolder <> "" Then 
        If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\" 
        FindFiles strFolder, strSearch, lngFilecount, Subfolder 
    End If 
End Sub 
 
Gruß Tino
Anzeige
ersetze den Code in Modul1 durch...
27.04.2010 09:50:02
Tino
Hallo,
diesen Code.
Sub KillPDFFiles()
Dim sfaPtr As Long
Dim nCount As Long
Dim strFilesName As String

'1. Parameter Optional Filter Standard = *; 
'2. Parameter Optional suche mit Unterordner Standard = False 
Call SucheDateien("*.pdf", False)

GetSafeArrayPointer strDateien, sfaPtr

'Tabelle1 eventuell anpassen 
If sfaPtr > 0 Then
    For nCount = Lbound(strDateien) To Ubound(strDateien)
        strFilesName = Right$(strDateien(nCount), Len(strDateien(nCount)) - InStrRev(strDateien(nCount), "\"))
        If Not IsNumeric(Application.Match(strFilesName, Tabelle1.UsedRange.Columns(1), 0)) Then
            Kill strDateien(nCount)
        End If
    Next nCount
End If

Erase strDateien
End Sub
Gruß Tino
Anzeige
AW: PDF Dateien löschen
27.04.2010 09:56:12
Rudi
Hallo,
brandgefährlich! Es gibt kein zurück!
Sub tt()
Dim sFile As String
Const sPfad As String = "c:\test\"
sFile = Dir(sPfad & "*.pdf")
Do
If Application.CountIf(Sheets(1).Columns(1), sPfad & sFile) = 0 Then Kill sFile
sFile = Dir
Loop Until sFile = ""
End Sub

Gruß
Rudi
AW: PDF Dateien löschen
27.04.2010 10:11:04
fcs
Hallo Valeri,
hier eine Version mit ein paar Sicherheitsabfragen. Dauert evtl. etwas länger, aber zumindest kann man ein Desaster verhindern durch Abbrechen der Ausführung.
Gruß
Franz
Sub PDF_loeschen()
Dim sPDF As String, sVerzeichnis As String, Zelle As Range, wks As Worksheet
Dim vAuswahl
Const sMsgTitle As String = "Alte Revisionen löschen"
Set wks = ActiveSheet
sVerzeichnis = "C:\Lokale Daten\Test\Zwischenordner" 'Zielordner ggf. anpassen
'Sicherheitsprüfung auf Dateierweiterung ".pdf"
Set Zelle = wks.Columns(1).Find(what:=".pdf", LookIn:=xlValues, lookat:=xlPart)
If Zelle Is Nothing Then '".Pdf" nicht gefunden
MsgBox "In Spalte A wurden keine Einträge mit "".pdf"" gefunden!" & vbLf _
& "Makro-Ausführung wird abgebrochen", _
vbInformation + vbOKOnly, sMsgTitle
Exit Sub
End If
If MsgBox("Alte Revisionen im Verzeichnis """ & sVerzeichnis & """ löschen?", _
vbQuestion + vbYesNo, sMsgTitle) = vbYes Then
'PDF-Dateien suchen im Verzeichnis
sPDF = Dir(sVerzeichnis & "\*.pdf")
If sPDF = "" Then
MsgBox "Keine PDF-Dateien gefunden im Verzeichnis """ & sVerzeichnis & """", _
vbInformation + vbOKOnly, sMsgTitle
GoTo Beenden
End If
'gefundene Dateinamen vergleichen
Do Until sPDF = ""
'PDF-Datei in Spalte A suchen
Set Zelle = wks.Columns(1).Find(what:=sPDF, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then 'Pdf nicht gefunden
vAuswahl = MsgBox("Datei """ & sVerzeichnis & "\" & sPDF & """ löschen?", _
vbQuestion + vbYesNoCancel + vbDefaultButton2, sMsgTitle)
Select Case vAuswahl
Case vbYes
Kill sVerzeichnis & "\" & sPDF
Case vbNo
'do nothing - nicht löschen
Case vbCancel
'Abbrechen Löschaktionen
GoTo Beenden
End Select
End If
'nächste PDF-Datei
sPDF = Dir
Loop
End If
MsgBox "Fertig", vbInformation + vbOKOnly, sMsgTitle
Beenden:
Set Zelle = Nothing: Set wks = Nothing
End Sub

Anzeige
an fcs AW: PDF Dateien löschen
27.04.2010 13:13:40
Valeri
Hallo Franz,
deine Lösung ist schon toll! Vielen Dank!
Alerdings Habe ich das mit Spalte A nur Hypotetisch hingeschrieben, in meiner Tabelle begine ich mit Spalte 22 Zelle 5. Erschwerend kommt noch hinzu das die Dokumentennummern mit Revision in dieser Spalte am Ende kein ".pdf" stehen haben sondern nur die reine Nummer.
Were Toll wenn Du deinen Code für mich noch anpassen würdest?
mfg Valeri
an fcs AW: PDF Dateien löschen
27.04.2010 18:29:39
fcs
Hallo Valeri,
um die klippen kommt man noch verhältnismäßig leicht herum.
Du muss jetzt noch ein wenig mehr aufpassen, wenn du versehentlich das makro startest.
Gruß
Franz
Sub PDF_loeschen()
Dim sPDF As String, sVerzeichnis As String, Zelle As Range, wks As Worksheet
Dim rBereich As Range, sSuchen As String
Dim vAuswahl
Const sMsgTitle As String = "Alte Revisionen löschen"
Set wks = ActiveSheet
sVerzeichnis = "C:\Lokale Daten\Test\Zwischenordner" 'Zielordner
If MsgBox("Alte Revisionen im Verzeichnis """ & sVerzeichnis & """ löschen?", _
vbQuestion + vbYesNo, sMsgTitle) = vbYes Then
'PDF-Dateien suchen im Verzeichnis
sPDF = Dir(sVerzeichnis & "\*.pdf")
If sPDF = "" Then
MsgBox "Keine PDF-Dateien gefunden im Verzeichnis """ & sVerzeichnis & """", _
vbInformation + vbOKOnly, sMsgTitle
GoTo Beenden
End If
'gefundene Dateinamen vergleichen
With wks
'Bereichn mit PDF-Dateinamen
Set rBereich = .Range(.Cells(5, 22), .Cells(.Rows.Count, 22).End(xlUp))
End With
Do Until sPDF = ""
'PDF-Datei in Spalte A suchen
sSuchen = Left(sPDF, Len(sPDF) - 4)
Set Zelle = rBereich.Find(what:=sSuchen, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then 'Pdf nicht gefunden
vAuswahl = MsgBox("Datei """ & sVerzeichnis & "\" & sPDF & """ löschen?", _
vbQuestion + vbYesNoCancel + vbDefaultButton2, sMsgTitle)
Select Case vAuswahl
Case vbYes
Kill sVerzeichnis & "\" & sPDF
Case vbNo
'do nothing - nicht löschen
Case vbCancel
'Abbrechen Löschaktionen
GoTo Beenden
End Select
End If
'nächste PDF-Datei
sPDF = Dir
Loop
End If
MsgBox "Fertig", vbInformation + vbOKOnly, sMsgTitle
Beenden:
ActiveSheet.Range("A:A").Delete
Set Zelle = Nothing: Set rBereich = Nothing: Set wks = Nothing
End Sub

Anzeige
an fcs AW: PDF Dateien löschen - Korrektur
28.04.2010 07:59:42
fcs
Hallo Valeri,
da war mir eine Zeile zuviel reingerutscht, die Spalte A löscht.
Hier die korrekte Version.
Gruß
Franz
Sub PDF_loeschen_ohne_PDF()
Dim sPDF As String, sVerzeichnis As String, Zelle As Range, wks As Worksheet
Dim rBereich As Range, sSuchen As String
Dim vAuswahl
Const sMsgTitle As String = "Alte Revisionen löschen"
Set wks = ActiveSheet
sVerzeichnis = "C:\Users\Public" 'Zielordner
If MsgBox("Alte Revisionen im Verzeichnis """ & sVerzeichnis & """ löschen?", _
vbQuestion + vbYesNo, sMsgTitle) = vbYes Then
'PDF-Dateien suchen im Verzeichnis
sPDF = Dir(sVerzeichnis & "\*.pdf")
If sPDF = "" Then
MsgBox "Keine PDF-Dateien gefunden im Verzeichnis """ & sVerzeichnis & """", _
vbInformation + vbOKOnly, sMsgTitle
GoTo Beenden
End If
'gefundene Dateinamen vergleichen
With wks
'Bereichn mit PDF-Dateinamen
Set rBereich = .Range(.Cells(5, 22), .Cells(.Rows.Count, 22).End(xlUp))
End With
Do Until sPDF = ""
'PDF-Datei in Spalte A suchen
sSuchen = Left(sPDF, Len(sPDF) - 4)
Set Zelle = rBereich.Find(what:=sSuchen, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then 'Pdf nicht gefunden
vAuswahl = MsgBox("Datei """ & sVerzeichnis & "\" & sPDF & """ löschen?", _
vbQuestion + vbYesNoCancel + vbDefaultButton2, sMsgTitle)
Select Case vAuswahl
Case vbYes
Kill sVerzeichnis & "\" & sPDF
Case vbNo
'do nothing - nicht löschen
Case vbCancel
'Abbrechen Löschaktionen
GoTo Beenden
End Select
End If
'nächste PDF-Datei
sPDF = Dir
Loop
MsgBox "Fertig", vbInformation + vbOKOnly, sMsgTitle
End If
Beenden:
Set Zelle = Nothing: Set rBereich = Nothing: Set wks = Nothing
End Sub

Anzeige
an fcs AW: PDF Dateien löschen - Korrektur
28.04.2010 15:32:00
Valeri
Hallo Franz,
deine Coole Lösung fand bei uns sofort einen regen Einsatz, auch in anderen bereichen um den Datenmüll zu minimieren.
Vielen Dank dafür!
Aus diesem Grund habe noch ein Änderungswunsch.
Ich möchte irgendwie den Code auch für eine oder zwei weitere Spalten erweitern können z.B. Zelle 5 Spalte 23.
Wie bekomme ich das hin?
mfg Valeri
an fcs AW: PDF Dateien löschen - Korrektur
28.04.2010 16:59:17
fcs
Hallo Valeri,
dazu muss der nach dem Namen zu durchsuchende Bereich in der folgenden Set-Anweisung entsprechend angepasst werden. Beispiele:
    With wks
'Bereich mit PDF-Dateinamen
'ab Zeile 5 Spalte 22 - zusammenhänger Bereich
Set rBereich = .Range(.Cells(5, 22), .Cells(.Rows.Count, 22))
'ab Zeile 5 Spalten 22 und 23 - zusammenhänger Bereich
Set rBereich = .Range(.Cells(5, 22), .Cells(.Rows.Count, 23))
'ab Zeile 5 Spalten 22 und 25 - nicht zusammenhänger Bereich
Set rBereich = Application.Union(.Range(.Cells(5, 22), .Cells(.Rows.Count, 22)), _
.Range(.Cells(5, 25), .Cells(.Rows.Count, 25)))
End With

Alternativ könnte man auch den zu durchsuchenen Tabellenbereich mit den Dateinamen vor dem Start des Makros markieren und die Selektion durchsuchen lassen.
Dann sieht der entsprechende Abschnitt mit der Bereichszuweisung so aus:
    'gefundene Dateinamen vergleichen
'Selektierter Zell-Bereich
Set rBereich = Selection
Do Until sPDF = ""

Gruß
Franz
Anzeige
Danke!!!!!
29.04.2010 15:01:28
Valeri
Hallo Franz,
genau das ist die Lösung.
Vielen liben Dank!
mfg Valeri

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige