mdmackillop,
Thanks. I am already using something similar to list all twenty files in Excel. I am not using the shell.exec because I have to avoid the command prompt that can sometimes show for several seconds or over a minute for very large folders.
Option Explicit
Const strFolder = "D:\My Documents\Word\Word Documents\Word Tips\Macros\Word FAQ Pages and Code\Customization\Templates\How to create a template that makes it easy for users to fill in the blanks, without doing any programming_files\FillinTheBlanksContent_files\"
Sub CreateFileList()
Dim strPath As String
Dim varFileList As Variant
Dim lngIndex As Long
Dim lngCounter As Long
Dim lngPosit As Long
Dim oWB As Workbook
Dim oSheet As Worksheet
Dim varTemp
strPath = strFolder 'Change to suit.
varFileList = fcnGetList(strPath, 1)
If UBound(varFileList) = -1 Then GoTo lbl_Exit
ReDim varTemp(1 To UBound(varFileList) + 1, 1 To 2)
For lngIndex = LBound(varFileList) To UBound(varFileList)
If varFileList(lngIndex) <> "" Then
lngCounter = lngCounter + 1
lngPosit = InStrRev(varFileList(lngIndex), "\")
'Lists files in first column/folders in second column.
varTemp(lngCounter, 1) = Mid(varFileList(lngIndex), lngPosit + 1, Len(varFileList(lngIndex)))
varTemp(lngCounter, 2) = Mid(varFileList(lngIndex), 1, lngPosit)
End If
Next lngIndex
Set oWB = ThisWorkbook
Set oSheet = oWB.Sheets(1)
oSheet.Range("A1").Resize(lngCounter, UBound(varTemp, 2)).Value = varTemp
oSheet.Sort.SortFields.Clear
oSheet.Sort.SortFields.Add key:=oSheet.Range("A1"), SortOn:=0, Order:=1, DataOption:=0
With oSheet.Sort
.SetRange oSheet.UsedRange
.Header = 1
.MatchCase = False
.Orientation = 1
.SortMethod = 1
.Apply
End With
Application.Columns("A:B").EntireColumn.AutoFit
lbl_Exit:
Set oWB = Nothing: Set oSheet = Nothing
Exit Sub
End Sub
Function fcnGetList(strFolder, lngRouter)
Dim strOutPut As String
Dim oShell, oFSO As Object
Dim lngIndex As Long
Dim varTemp
If Not Right(strFolder, 1) = "\" Then strFolder = strFolder & "\"
Set oShell = CreateObject("wscript.shell")
'Note, I used this method to avoid the black command prompt that is displayed if Shell.Exec is used.
Select Case lngRouter
Case 1: oShell.Run "cmd /c Dir """ & strFolder & "*"" /a:-d/s/ogn/b > C:\FileListOut.txt", 0, 1
Case 2: oShell.Run "cmd /c Dir """ & strFolder & "*"" /a:-d/ogn/b > C:\FileListOut.txt", 0, 1
End Select
Set oFSO = CreateObject("Scripting.FileSystemObject")
With oFSO
strOutPut = .OpenTextFile("C:\FileListOut.txt").ReadAll()
.DeleteFile "C:\FileListOut.txt"
End With
If Right(strOutPut, 1) = Chr(10) Then strOutPut = Left(strOutPut, Len(strOutPut) - 1)
varTemp = Split(strOutPut, vbCrLf)
If lngRouter = 2 Then
For lngIndex = 0 To UBound(varTemp)
varTemp(lngIndex) = strFolder & varTemp(lngIndex)
Next lngIndex
End If
fcnGetList = varTemp
lbl_Exit:
Set oShell = Nothing: Set oFSO = Nothing
Exit Function
End Function
Public Function fcnFileOrFolderExist(PathName As String) As Boolean
Dim lngTemp As Long
On Error Resume Next
lngTemp = GetAttr(PathName)
Select Case Err.Number
Case Is = 0: fcnFileOrFolderExist = True
Case Else
fcnFileOrFolderExist = False
End Select
On Error GoTo 0
lbl_Exit:
Exit Function
End Function
The problem is, after I get the list of files in that manner, the user may need to get the attributes for one or more (all) of the listed files. The code for that:
Sub FillInFileDetails()
Dim oSheet As Worksheet
Dim oRow As Range
Dim oFSO As Object
Dim oFile As Object
Dim lngCount As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oSheet = ActiveSheet
lngCount = 0
On Error GoTo Err_File
For Each oRow In oSheet.Rows
If oSheet.Cells(oRow.Row, 1).Value = "" Then Exit For
lngCount = lngCount + 1
Set oFile = oFSO.GetFile(oSheet.Cells(lngCount, 2) & oSheet.Cells(lngCount, 1))
With oSheet
.Cells(lngCount, 3).Value = oFile.DateCreated
.Cells(lngCount, 4).Value = oFile.DateLastAccessed
.Cells(lngCount, 5).Value = oFile.DateLastModified
.Cells(lngCount, 6).Value = oFile.Size
.Cells(lngCount, 7).Value = oFile.Type
End With
Err_ReEntry:
DoEvents
Next oRow
On Error GoTo 0
lbl_Exit:
Exit Sub
Err_File:
oSheet.Cells(lngCount, 3).Value = "Error accessing file"
Resume Err_ReEntry
End Sub
For the particular folder (even though there are 20 files) and the Folder count returns 20 as my picture illustrates, there are only four items! Thanks.
Reply With Quote
