Pulling folder content file info into worksheet

[Coltrane59]

I have a macro to pull the file details into a spreadsheet for all files in a selected directory folder.

I'm trying to modify it to include a column for each files 'Author', but I'm not having any luck - I don't know that much VBA.

Any suggestions?

Here's the code I found:

[VBA]Option Compare Text
Option 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

[/VBA]

[Benzadeus]

What kind of document do you want to extract author's name? This example contemplates Excel Workbooks:

*The method I used open each workbook to extract author's name, because I can't figure another way.

[VBA]Option Compare Text
Option 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
Dim wb As Workbook

'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
With .Offset(0, 3)
.ColumnWidth = 15
.Value = "Author"
.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
With .Offset(0, 3)
If Right(File.Path, 3) = "xls" Then
Set wb = Workbooks.Open(File)
.Value = wb.BuiltinDocumentProperties("Author").Value
wb.Close
End If
End With
End With
End With
End If
Next
End Sub[/VBA]

[Coltrane59]

Thanks for the reply - interesting solution. The folder has a mix of xls, pdf, doc, and ppt files. The .pdf ones don't have an author from what I can see though. Basically, I want it to pull the same Author info that would be available if you were in Windows Explorer view and selected "Author" as one of the fields to display in the folder details.

Also, my folder has about 230 files in it, so I'm not sure I want to have to open the workbooks to get the info, but if that's the only way, maybe I'll just let it run and go do something in the meantime.

Thanks!

[Coltrane59]

So, just tried it out...didn't take that long, but it does bring up the "Update" (links) dialog box for workbooks that have links in them. Also, when closing, some workbooks had a dialog box that asked whether to save or not.

Is there a way to pull the author info for .doc documents as well?

[Benzadeus]

Try using this late binding example...
[VBA]Option Compare Text
Option 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
Dim wb As Workbook
Dim wdApp As Object
Dim ppApp As Object
Dim ppPres As Object
Dim wdDoc As Object
'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
With .Offset(0, 3)
.ColumnWidth = 15
.Value = "Author"
.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
With .Offset(0, 3)
If Right(File.Path, 3) = "xls" Then
Set wb = Workbooks.Open(File)
.Value = wb.BuiltinDocumentProperties("Author").Value
wb.Close
End If
If Right(File.Path, 3) = "ppt" Then
On Error Resume Next
Set ppApp = GetObject(, "Powerpoint.Application")
If Err.Number = 429 Then
Set ppApp = CreateObject("Powerpoint.Application")
End If
On Error GoTo 0
ppApp.Visible = True
Set ppPres = ppApp.Presentations.Open(File)
.Value = ppPres.BuiltinDocumentProperties("Author").Value
ppPres.Close
End If
If Right(File.Path, 3) = "doc" Then
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open("""" & File & """")
.Value = wdDoc.BuiltinDocumentProperties("Author").Value
wdDoc.Close
End If
If Right(File.Path, 3) = "xls" Then
Set wb = Workbooks.Open(File)
.Value = wb.BuiltinDocumentProperties("Author").Value
wb.Close False
End If
End With
End With
End With
End If
Next
On Error Resume Next
ppApp.Quit
wdApp.Quit
On Error GoTo 0

Set ppApp = Nothing
Set wdApp = Nothing
End Sub[/VBA]

[Sprinter]

Sorry to bring an old thread back to life, but I am trying to implement the script in this thread (similar to "Create Hyperlinked List of Directory Contents" example), but I am wanting to list the files found not only in the directory specified when you make a selection, but also all the sub folders within that directory.

Thank you for any help.

[Benzadeus]

Try using RECURSION, as described, for example, here:

http://technet.microsoft.com/en-us/l.../ee198721.aspx
http://blogs.technet.com/heyscriptin...ubfolders.aspx

[Benzadeus]

Maybe something like this... (not fully tested)

[VBA]Option Compare Text
Option 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, _
Folder As Object, _
SubFolder As Object, _
Directory As String, _
Problem As Boolean, _
ExcelVer As Integer
Dim wb As Workbook
Dim wdApp As Object
Dim ppApp As Object
Dim ppPres As Object
Dim wdDoc As Object
'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 Folder = 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
With .Offset(0, 3)
.ColumnWidth = 15
.Value = "Author"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
End With
End With
'Adds each file, details and hyperlinks to the list

For Each SubFolder In Folder.SubFolders
GetInformation SubFolder
Next SubFolder
End Sub

Sub GetInformation(Folder As Object)
For Each File In Folder.Files
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
With .Offset(0, 3)
If Right(File.Path, 3) = "xls" Then
Set wb = Workbooks.Open(File)
.Value = wb.BuiltinDocumentProperties("Author").Value
wb.Close
End If
If Right(File.Path, 3) = "ppt" Then
On Error Resume Next
Set ppApp = GetObject(, "Powerpoint.Application")
If Err.Number = 429 Then
Set ppApp = CreateObject("Powerpoint.Application")
End If
On Error GoTo 0
ppApp.Visible = True
Set ppPres = ppApp.Presentations.Open(File)
.Value = ppPres.BuiltinDocumentProperties("Author").Value
ppPres.Close
End If
If Right(File.Path, 3) = "doc" Then
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open("""" & File & """")
.Value = wdDoc.BuiltinDocumentProperties("Author").Value
wdDoc.Close
End If
If Right(File.Path, 3) = "xls" Then
Set wb = Workbooks.Open(File)
.Value = wb.BuiltinDocumentProperties("Author").Value
wb.Close False
End If
End With
End With
End With
End If
Next
On Error Resume Next
ppApp.Quit
wdApp.Quit
On Error GoTo 0

Set ppApp = Nothing
Set wdApp = Nothing
End Sub
[/VBA]