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.

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