Option Explicit
Public varFileArray() As Variant
Sub Call_ListFilesInFolder()
Dim sWorksheet As String
Dim lRowCount As Long
'Reset Output Worksheet
sWorksheet = "Files to Print"
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(sWorksheet).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Worksheets.Add(after:=Sheets(Sheets.Count)).Name = sWorksheet 'After last
Worksheets(sWorksheet).Range("A1").Resize(1, 5).Value = Array("File Name Ext", "Path", "Created", "Modified", "Accessed")
'Create Array of Files to Print (see info in CreateFilesArray module on arguments for this sub)
CreateFilesArray "G:\Proj", "Summary Log", "*.xls*", True
'Copy Array to Output Worksheet
lRowCount = UBound(varFileArray, 2)
With Worksheets(sWorksheet)
.Range("A2").Resize(lRowCount, 5).Value = Application.Transpose(varFileArray)
End With
'Option to Print all files
Select Case MsgBox("There are " & UBound(varFileArray, 2) & " files to be printed. " & vbLf & vbLf & _
"They are listed on the 'Files to Print' worksheet." & vbLf & vbLf & _
"Do you want to print them now?", vbYesNo, "Print Files?")
Case vbYes
PrintFilesOnOutputWorksheet
Case Else
MsgBox "Print Cancelled"
End Select
End Sub
Sub PrintFilesOnOutputWorksheet()
Dim sFilePathNameExt As String
Dim lRowIndex As Long
Dim lLastRow As Long
Dim wbk As Workbook
Dim secAutomation As MsoAutomationSecurity
secAutomation = Application.AutomationSecurity 'Save ThisWorkbook security setting
Application.AutomationSecurity = msoAutomationSecurityForceDisable 'Disable macros when opening file
With Worksheets("Files to Print")
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For lRowIndex = 2 To lLastRow
sFilePathNameExt = .Cells(lRowIndex, 2).Value & .Cells(lRowIndex, 1).Value
' Open workbook
Set wbk = Workbooks.Open(Filename:=sFilePathNameExt, AddToMRU:=False, ReadOnly:=True)
' Do something with the workbook
'ActiveSheet.PrintOut
Debug.Print .Cells(lRowIndex, 1).Value & ", ",
' Close it
wbk.Close SaveChanges:=False
Next
End With
Set wbk = Nothing
Application.AutomationSecurity = secAutomation 'Restore ThisWorkbook security setting
End Sub
Function CreateFilesArray(sSourceFolderName As String, sTargetSubfolder As String, sFilePattern As String, bIncludeSubfolders As Boolean) As Variant
'sSourceFolderName Folder to start search in
'sTargetSubfolder Name of the subfolder(s) that contain the file(s) to be printed
' There may be multiple subfolders with this name. Files with this name in their path will be print candiates
'sFilePattern If a print candidate FileNameExt matches this pattern then it will be printed
'bIncludeSubfolders True if folders under the sSourceFolderName folder should be searched
' False to search only the sSourceFolderName folder
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim SourceFolder As Object
If LenB(sTargetSubfolder) = 0 Then sTargetSubfolder = "*"
Dim SubFolder As Object
Set SubFolder = FSO.GetFolder(sSourceFolderName)
Dim FileItem As Object
Dim lMatchingFileCount As Long
Dim lFileCount As Long
Set SourceFolder = FSO.GetFolder(sSourceFolderName)
lFileCount = 0
On Error Resume Next
lMatchingFileCount = UBound(varFileArray, 2)
If Err.Number <> 0 Then lMatchingFileCount = 0
On Error GoTo 0
If InStr(SourceFolder.Path & "\", "\" & sTargetSubfolder & "\") > 0 Then
Debug.Print SourceFolder.Path & "\"
For Each FileItem In SourceFolder.Files
lFileCount = lFileCount + 1
' display file properties
'Debug.Print FileItem.Name
If FileItem.Name Like sFilePattern Then
lMatchingFileCount = lMatchingFileCount + 1 ' next row number
ReDim Preserve varFileArray(1 To 5, 1 To lMatchingFileCount)
varFileArray(1, lMatchingFileCount) = FileItem.Name
varFileArray(2, lMatchingFileCount) = Left(FileItem.Path, InStrRev(FileItem.Path, "\"))
varFileArray(3, lMatchingFileCount) = FileItem.DateCreated
varFileArray(4, lMatchingFileCount) = FileItem.DateLastModified
varFileArray(5, lMatchingFileCount) = FileItem.DateLastAccessed
End If
Next FileItem
'Debug.Print lFileCount, lMatchingFileCount, SourceFolder.Name
End If
If bIncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
CreateFilesArray SubFolder.Path, sTargetSubfolder, sFilePattern, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Function
