Export list of folder including the last modified date

I found the following code to export a list of subfolders within a particular folder in Outlook. I am looking for a way to include the last modified date of the each folder as well (i.e. the date of the most recent email in the subfolder).

Can anyone suggest anything?

Thank you.

Code:

---

Private MyFile As StringPrivate Structured As Boolean
Private Base As Integer


Public Sub ExportFolderNames()
  Dim F As Outlook.MAPIFolder
  Dim Folders As Outlook.Folders


  Set F = Application.ActiveExplorer.CurrentFolder
  Set Folders = F.Folders
 
  Dim Result As Integer
  Result = MsgBox("Do you want to structure the output?", vbYesNo + vbDefaultButton2 + vbApplicationModal, "Output structuring")
  If Result = 6 Then
    Structured = True
  Else
    Structured = False
  End If
 
  MyFile = GetDesktopFolder() & "\outlookfolders.txt"
  Base = Len(F.FolderPath) - Len(Replace(F.FolderPath, "\", "")) + 1
 
  WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name))
 
  LoopFolders Folders
 
  Set F = Nothing
  Set Folders = Nothing
End Sub


Public Sub ExportFolderNamesSelect()
  Dim F As Outlook.MAPIFolder
  Dim Folders As Outlook.Folders
 
  Set F = Application.Session.PickFolder
 
  If Not F Is Nothing Then
    Set Folders = F.Folders
 
    Dim Result As Integer
    Result = MsgBox("Do you want to structure the output?", vbYesNo + vbDefaultButton2 + vbApplicationModal, "Output structuring")
    If Result = 6 Then
      Structured = True
    Else
      Structured = False
    End If
 
    MyFile = GetDesktopFolder() & "\outlookfolders.txt"
    Base = Len(F.FolderPath) - Len(Replace(F.FolderPath, "\", "")) + 1
   
    WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name))
 
    LoopFolders Folders
 
    Set F = Nothing
    Set Folders = Nothing
  End If
End Sub


Private Function GetDesktopFolder()
  Dim objShell
  Set objShell = CreateObject("WScript.Shell")
  GetDesktopFolder = objShell.SpecialFolders("Desktop")
  Set objShell = Nothing
End Function


Private Sub LoopFolders(Folders As Outlook.Folders)
  Dim F As Outlook.MAPIFolder
   
  For Each F In Folders
    WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name))
    LoopFolders F.Folders
  Next
End Sub


Private Sub WriteToATextFile(OLKfoldername As String)
  fnum = FreeFile()
   
  Open MyFile For Append As #fnum
    Print #fnum, OLKfoldername
  Close #fnum
End Sub


Private Function StructuredFolderName(OLKfolderpath As String, OLKfoldername As String) As String
  If Structured = False Then
    StructuredFolderName = Mid(OLKfolderpath, 3)
  Else
    Dim i As Integer
    i = Len(OLKfolderpath) - Len(Replace(OLKfolderpath, "\", ""))
   
    Dim x As Integer
    Dim OLKprefix As String
    For x = Base To i
      OLKprefix = OLKprefix & "-"
    Next x
   
    StructuredFolderName = OLKprefix & OLKfoldername & OL
  End If
End Function

---

Look at the section towards the bottom.

Code:

---

Option Compare TextOption Explicit
 
Function Excludes(Ext As String) As Boolean
    'Function purpose:  To exclude listed file extensions from hyperlink listing
   
    Dim X, NumPos As Long
   
    'Enter/adjust file extensions to EXCLUDE from listing here:
    X = Array("exe", "bat", "dll", "zip")
   
    On Error Resume Next
    NumPos = Application.WorksheetFunction.Match(Ext, X, 0)
    If NumPos > 0 Then Excludes = True
    On Error GoTo 0
   
End Function
 
Sub HyperlinkFileList()
    'Macro purpose:  To create a hyperlinked list of all files in a user
    'specified directory, including file size and date last modified
    'NOTE:  The 'TextToDisplay' property (of the Hyperlink object) was added
    'in Excel 2000.  This code tests the Excel version and does not use the
    'Texttodisplay property if using XL 97.
   
    Dim FSO As Object, _
    ShellApp As Object, _
    File As Object, _
    SubFolder As Object, _
    Directory As String, _
    Problem As Boolean, _
    ExcelVer As Integer
   
    'Turn off screen flashing
    Application.ScreenUpdating = False
   
    'Create objects to get a listing of all files in the directory
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    'Prompt user to select a directory
    Do
        Problem = False
        Set ShellApp = CreateObject("Shell.Application"). _
        Browseforfolder(0, "Please choose a folder", 0, "c:\\")
       
        On Error Resume Next
        'Evaluate if directory is valid
        Directory = ShellApp.self.Path
        Set SubFolder = FSO.GetFolder(Directory).Files
        If Err.Number <> 0 Then
            If MsgBox("You did not choose a valid directory!" & vbCrLf & _
            "Would you like to try again?", vbYesNoCancel, _
            "Directory Required") <> vbYes Then Exit Sub
            Problem = True
        End If
        On Error GoTo 0
    Loop Until Problem = False
   
    'Set up the headers on the worksheet
    With ActiveSheet
        With .Range("A1")
            .Value = "Listing of all files in:"
            .ColumnWidth = 40
            'If Excel 2000 or greater, add hyperlink with file name
            'displayed.  If earlier, add hyperlink with full path displayed
            If Val(Application.Version) > 8 Then 'Using XL2000+
                .Parent.Hyperlinks.Add _
                Anchor:=.Offset(0, 1), _
                Address:=Directory, _
                TextToDisplay:=Directory
            Else 'Using XL97
                .Parent.Hyperlinks.Add _
                Anchor:=.Offset(0, 1), _
                Address:=Directory
            End If
        End With
        With .Range("A2")
            .Value = "File Name"
            .Interior.ColorIndex = 15
            With .Offset(0, 1)
                .ColumnWidth = 15
                .Value = "Date Modified"
                .Interior.ColorIndex = 15
                .HorizontalAlignment = xlCenter
            End With
            With .Offset(0, 2)
                .ColumnWidth = 15
                .Value = "File Size (Kb)"
                .Interior.ColorIndex = 15
                .HorizontalAlignment = xlCenter
            End With
        End With
    End With
   
    'Adds each file, details and hyperlinks to the list
    For Each File In SubFolder
        If Not Excludes(Right(File.Path, 3)) = True Then
            With ActiveSheet
                'If Excel 2000 or greater, add hyperlink with file name
                'displayed.  If earlier, add hyperlink with full path displayed
                If Val(Application.Version) > 8 Then 'Using XL2000+
                    .Hyperlinks.Add _
                    Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
                    Address:=File.Path, _
                    TextToDisplay:=File.Name
                Else 'Using XL97
                    .Hyperlinks.Add _
                    Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
                    Address:=File.Path
                End If


'##########################################################################################


                'Add date last modified, and size in KB
                With .Range("A65536").End(xlUp)
                    .Offset(0, 1) = File.DateLastModified
                    With .Offset(0, 2)
                        .Value = WorksheetFunction.Round(File.Size / 1024, 1)
                        .NumberFormat = "#,##0.0"
                    End With
                End With


'##########################################################################################




            End With
        End If
    Next
   
End Sub

---

The attached workbook "List The Files ..." is another example :

Code:

---

'Force the explicit delcaration of variablesOption Explicit


Sub ListFiles()


    'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)
   
    'Declare the variables
    Dim objFSO As Scripting.FileSystemObject
    Dim objTopFolder As Scripting.Folder
    Dim strTopFolderName As String
   
    'Insert the headers for Columns A through F
    Range("A1").Value = "File Name"
    Range("B1").Value = "File Size"
    Range("C1").Value = "File Type"
    Range("D1").Value = "Date Created"
    Range("E1").Value = "Date Last Accessed"
    Range("F1").Value = "Date Last Modified"
   
    'Assign the top folder to a variable
    strTopFolderName = "C:\Users\jimga\Desktop"
   
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
   
    'Get the top folder
    Set objTopFolder = objFSO.GetFolder(strTopFolderName)
   
    'Call the RecursiveFolder routine
    Call RecursiveFolder(objTopFolder, True)
   
    'Change the width of the columns to achieve the best fit
    Columns.AutoFit
   
End Sub


Sub RecursiveFolder(objFolder As Scripting.Folder, _
    IncludeSubFolders As Boolean)


    'Declare the variables
    Dim objFile As Scripting.File
    Dim objSubFolder As Scripting.Folder
    Dim NextRow As Long
   
    'Find the next available row
    NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
   
    'Loop through each file in the folder
    For Each objFile In objFolder.Files
        Cells(NextRow, "A").Value = objFile.Name
        Cells(NextRow, "B").Value = objFile.Size
        Cells(NextRow, "C").Value = objFile.Type
        Cells(NextRow, "D").Value = objFile.DateCreated
        Cells(NextRow, "E").Value = objFile.DateLastAccessed
        Cells(NextRow, "F").Value = objFile.DateLastModified
        NextRow = NextRow + 1
    Next objFile
   
    'Loop through files in the subfolders
    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.SubFolders
            Call RecursiveFolder(objSubFolder, True)
        Next objSubFolder
    End If
   
End Sub

---