手動で各フォルダを選択する代わりに、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