AW: Alle Unterordner löschen
19.01.2011 10:33:08
Case
Hallo,
habe das jetzt nur an ein paar Odnern getestet. Also probiere es erst mal in einer Testumgebung. Falls Du keine Ordnerauswahl möchtest, sondern den Ordner fest vorgeben willst musst Du diese Zeile anpassen:
strTMP = fncFolder("C:\")
In z. B. sowas:
strTMP = "C:\Test\Ordner\" 'fncFolder("C:\")
Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" _
(ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" (ByVal lpPathName$) As Long
Dim strParentFolder As String
Dim objSubFolder As Object
Dim objTMPFolder As Object
Dim objFolder As Object
Dim objFSO As Object
Public Sub Emty_Folder_List()
Dim strDirOld As String
Dim strTMP As String
On Error GoTo Fin
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, _
InStr(1, strDirOld$, vbNullChar) - 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTMP = fncFolder("C:\")
If strTMP "" Then getSubFolders strTMP
Fin:
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Call SetCurrentDirectory(strDirOld$)
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub
Private Function getSubFolders(strTMPPath)
Set objFolder = objFSO.GetFolder(strTMPPath)
Set objSubFolder = objFolder.SubFolders
For Each objTMPFolder In objSubFolder
If objTMPFolder.Files.Count = 0 And _
objTMPFolder.SubFolders.Count = 0 Then
strParentFolder = objTMPFolder.ParentFolder.Path
objFSO.DeleteFolder objTMPFolder, True
getSubFolders strParentFolder
Else
getSubFolders objTMPFolder.Path
End If
Next
End Function
Private Function fncFolder(strPath As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = strPath
.Title = "Folder"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) "\" Then strPath = strPath & "\"
Else
strPath = ""
End If
End With
fncFolder = strPath
End Function
Servus
Case