Export list of folder including the last modified date

[LVG8R]

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

[Logit]

Look at the section towards the bottom.



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 :


'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