Try this, to list file information from a folder you select from the included Dialog:
Sub Get_Files_With_FSO()
'Standard code module only, like: Module1.
Dim objFSO As Object, objFolder As Object
Dim objFiles As Object, objThisFile As Object
Dim strDirectory$, strMyFolder$, strMyFilePath$
Dim ws As Worksheet
Dim wb As Workbook
Dim lngRowInfo&
Application.DisplayAlerts = False
On Error GoTo myError
'Display Folder Shell, for you to select your Folder, Option Switches:
'BrowseForFolder(hwnd,Title,ulFlags,RootFolder)= hwnd==> "handle to the parent window of the dialog box.
'0 Zero is the current window"
'BrowseForFolder(hwnd,Title,ulFlags,RootFolder)= Title==> "Custom Title for Dialog Box"
'BrowseForFolder(hwnd,Title,ulFlags,RootFolder)= ulFlags==> "ulFlags as listed below!"
'ulFlags: 0 Zero(Default No Restriction [Best to Use!]) or a combination of the following values.
'BIF_BROWSEFORCOMPUTER(Only computers anything else, the OK button is grayed.)
'BIF_BROWSEFORPRINTER(Only printersanything else, the OK button is grayed. Note:
'In Windows XP, use an XP-style dialog, setting the root to Printers and Faxes folder (CSIDL_PRINTERS).)
'BIF_BROWSEINCLUDEFILES(Version 4.71. The browse dialog box will display files as well as folders.)
'BIF_DONTGOBELOWDOMAIN(Do not include network folders below domain level in box's tree view control.)
'BIF_NOTRANSLATETARGETS(Version 6.0. If selected item is: shortcut, return the PIDL of the shortcut itself
'rather than its target.)
'BIF_RETURNFSANCESTORS(Only return file system ancestors: The subfolder that is beneath the root folder
'in the namespace hierarchy. If the ancestor is not part of the file system, the OK button is grayed.)
'BIF_RETURNONLYFSDIRS(Only file system directories, if not part of the file system, the OK button is grayed.)
'BrowseForFolder(hwnd,Title,ulFlags,RootFolder)= RootFolder==> "Root Folder Option, as listed below!"
'Current-Folder==>Left(CurDir, 3), 17=AllFilesDeskTop(MyComputer), 0=Root(DeskTop), 28=ApplicationData,
'8=Recent, 23=Common(Programs), 2=Top(Programs), 38=All(Programs), 3=Controls, 39=Pictures,
'5=MyDocuments, 4=Printers&Faxs, 27=PrintHood, 32=TempInternet, 20=Fonts, 34=InternetHistory,
'11=StartMenu, 7=StartUp(Only), 21=Templates, 36=Windows , 39=MyPictures, 33=cookies,
'16=DeskTop, 6=Favorites,18=Network, 19=NetHood, 5=Personal(MyDocuments), 40=UserProfile,
'9=SendToMenuItems, 37=System.
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please Select a Folder!", 0, 17)
'Condition Folder for RootFolder or SubFolder Path!
If Not objFolder Is Nothing Then
If Len(objFolder.Items.Item.Path) > 3 Then
strMyFolder = objFolder.Items.Item.Path & Application.PathSeparator
Else
strMyFolder = objFolder.Items.Item.Path
End If
End If
'Hold your selected Folder for use!
ChDir strMyFolder
strMyFilePath = strMyFolder
'Build Folder's Files list!
Set objFSO = CreateObject("scripting.filesystemobject")
Set objFolder = objFSO.GetFolder(strMyFilePath)
Set objFiles = objFolder.Files
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Insert New Sheet to hold Files list!
Set ws = Worksheets.Add
'Label File Information list!
With ws
.Cells(1, 1) = "Path: " & strMyFilePath: .Cells(1, 2) = "Name": .Cells(1, 3) = "Creation Date": .Cells(1, 4) = _
"Creation Author": .Cells(1, 5) = "Last Save Time": .Cells(1, 6) = "Last Author"
.Rows(1).Font.Bold = True
End With
'Add File information to sheet!
lngRowInfo = 2
For Each objThisFile In objFiles
If objThisFile.Type = "Microsoft Excel Worksheet" Then
Set wb = Workbooks.Open(strMyFilePath & "\" & objThisFile.Name, UpdateLinks:=False, ReadOnly:=True)
With ws
.Cells(lngRowInfo, 1) = strDirectory
.Cells(lngRowInfo, 2) = objThisFile.Name
.Cells(lngRowInfo, 3) = wb.BuiltinDocumentProperties("Creation Date")
.Cells(lngRowInfo, 4) = wb.BuiltinDocumentProperties("Author")
.Cells(lngRowInfo, 5) = wb.BuiltinDocumentProperties("Last Save Time")
.Cells(lngRowInfo, 6) = wb.BuiltinDocumentProperties("Last Author")
End With
wb.Close SaveChanges:=False
lngRowInfo = lngRowInfo + 1
End If
Next objThisFile
With ws
.Range("C:F").NumberFormat = "dd mmmm yyyy"
.Columns.AutoFit
End With
Exit Sub
'On Error Display: Error-information and Help option!
myError:
MsgBox "On ""OK"" will Exit you back to your sheet!" & vbLf & vbLf & _
"Error Source: " & Err.Source & vbLf & _
"Error Number: " & Err.Number & vbLf & _
"Error Type: " & Err.Description & vbLf _
, vbMsgBoxHelpButton _
, "Error Accessing, " & strMyFilePath & ", Drive: " & myDrive _
, Err.HelpFile _
, Err.HelpContext
GoTo myEnd
myEnd:
End Sub
Function GetFolder() As String
'Standard code module only, like: Module1.
Dim strItem$
Dim objFolderDialog As Object
Set objFolderDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFolderDialog
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
strItem = .SelectedItems(1)
End With
NextCode:
GetFolder = strItem
Set objFolderDialog = Nothing
End Function
