如何讓VBA循環通過用戶定義的文件夾，而不是手動選擇每個文件夾

Question

Sub DeleteOld() 

Dim oFolder As Folder 
Dim dDate As Date 
Dim ItemsOverDate As Outlook.Items 
Dim dDays As Integer 

Dim DateToCheck As String 

dDays = InputBox("How many days?") 

dDate = DateAdd("d", -dDays, Now()) 
dDate = Format(dDate, "dd/mm/yyyy") 


Set oFolder = Application.Session.PickFolder 'or set your folder 

DateToCheck = "[Received] <= """ & dDate & """" 

Set ItemsOverDate = oFolder.Items.Restrict(DateToCheck) 

For i = ItemsOverDate.Count To 1 Step -1 
    ItemsOverDate.Item(i).Delete 
Next 


Set ItemsOverDate = Nothing 
Set oFolder = Nothing 


End Sub 

Answer 1

我認爲這是您的需求。

Public FSO As New FileSystemObject 

Private Sub DeleteOld() 
MasterFolderDir = "LOCATION OF THE FOLDER THAT HOLDS ALL THE ONES YOU WANT TO DELETE" 
iDate = InputBox("How many days?") 
    For Each Folder In FSO.GetFolder(MasterFolderDir).SubFolders 
     If DateDiff("d", Folder.DateCreated, Now) > iDate Then 
      Folder.Delete 
     End If 
    Next 
End Sub 

讓我知道它是否適合您。我沒有測試它。

Answer 2

您需要一個遞歸腳本來鑽取文件夾，這些文件夾中的子文件夾以及這些子文件夾中的子文件夾。

Sub GetFolder_Data_Collection() 

Range("A:L").ClearContents 
Range("A1").Value = "Name" 
Range("B1").Value = "Path" 
Range("C1").Value = "Size (KB)" 
Range("D1").Value = "DateLastModified" 
Range("E1").Value = "Attributes" 
Range("F1").Value = "DateCreated" 
Range("G1").Value = "DateLastAccessed" 
Range("H1").Value = "Drive" 
Range("I1").Value = "ParentFolder" 
Range("J1").Value = "ShortName" 
Range("K1").Value = "ShortPath" 
Range("L1").Value = "Type" 
Range("A1").Select 

Dim strPath As String 
'strPath = "I:\Information Security\KRI Monthly Data Collection\" 
strPath = GetFolder 

Dim OBJ As Object, Folder As Object, File As Object 

Set OBJ = CreateObject("Scripting.FileSystemObject") 
Set Folder = OBJ.GetFolder(strPath) 

Call ListFiles(Folder) 

Dim SubFolder As Object 

For Each SubFolder In Folder.SubFolders 
    Call ListFiles(SubFolder) 
    Call GetSubFolders(SubFolder) 
Next SubFolder 


End Sub 

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 

Sub ListFiles(ByRef Folder As Object) 

On Error Resume Next 
For Each File In Folder.Files 
     ActiveCell.Offset(1, 0).Select 
     ActiveCell = File.Name 
     ActiveCell.Offset(0, 1).Select 
     ActiveCell.Offset(0, 1) = File.Path 
      ActiveCell.Offset(0, 0).Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 0), Address:=File.Path, TextToDisplay:=File.Path 
     ActiveCell.Offset(0, -1).Select 
     ActiveCell.Offset(0, 2) = (File.Size/1024) 'IN KB 
     ActiveCell.Offset(0, 3) = File.DateLastModified 
     ActiveCell.Offset(0, 4) = File.Attributes 
     ActiveCell.Offset(0, 5) = File.DateCreated 
     ActiveCell.Offset(0, 6) = File.DateLastAccessed 
     ActiveCell.Offset(0, 7) = File.Drive 
     ActiveCell.Offset(0, 8) = File.ParentFolder 
     ActiveCell.Offset(0, 9) = File.ShortName 
     ActiveCell.Offset(0, 10) = File.ShortPath 
     ActiveCell.Offset(0, 11) = File.Type 
Next File 

End Sub 

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 

Sub GetSubFolders(ByRef SubFolder As Object) 

Dim FolderItem As Object 
On Error Resume Next 
For Each FolderItem In SubFolder.SubFolders 
    Call ListFiles(FolderItem) 
    Call GetSubFolders(FolderItem) 
Next FolderItem 

End Sub 


Function GetFolder() As String 
    Dim fldr As FileDialog 
    Dim sItem As String 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
     .Title = "Select a Folder" 
     .AllowMultiSelect = False 
     .InitialFileName = Application.DefaultFilePath 
     If .Show <> -1 Then GoTo NextCode 
     sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function