Getfile name - and more - from a directory

[Brook70458]

I have been using this macro for several years and it has proven a great timesaver. I have tried modifying it to add the file datestamp (created and modified) to no avail; and it would be greatly beneficial to add type and size.

[ALSO, as a reference, what is a good book for data minig using MSExcel?]

Thank you in advance

Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Sub GetFileNames()
Dim lRow As Long
Dim sPath As String
Dim sFname As String

sPath = GetFolderName("Select a folder")
If sPath = "" Then
Exit Sub
End If
sPath = sPath & "/"
lRow = 1
Cells(lRow, "a").Value = sPath
sFname = Dir(sPath & "*.*", vbNormal)
Do Until sFname = vbNullString
lRow = lRow + 1
Cells(lRow, "a").Value = sFname
sFname = Dir
Loop
End Sub


Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function

 

[Leith Ross]

Hello Brook70458,

While the information you are seeking can be retrieved using the Windows API, it is a lot easier to use the Shell. This is the standard interface used by Windows Explorer when listing files and folders. The code below let's you select the folder whose files you want to list. It will provide the folder path, the file name, the file extension, the file type, the size, the date last modified, the date of creation, and the owner.

The default output is to "Sheet1" starting in cell A1. Row 1 contains the headers. You can change the sheet name in the code if you want the output to a different sheet. Copy the code below and paste it into a new VBA module in your workbook.

Macro to List Files with Meta Data

Sub ListFoldersWithDetails()

    Dim Data        As Variant
    Dim File        As Object
    Dim FileInfo    As Variant
    Dim Files       As Object
    Dim FileType    As String
    Dim Folder      As Object
    Dim Headers     As Variant
    Dim Item        As Variant
    Dim j           As Long
    Dim k           As Long
    Dim n           As Long
    Dim oShell      As Object
    Dim Path        As Variant
    Dim Rng         As Range
    Dim Wks         As Worksheet
    
        Set oShell = CreateObject("Shell.Application")
        
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        Set Rng = Wks.Range("A2")
        
        Headers = Array("Folder", "Name", "Ext.", "Size", "Type", "Date Modified", "Date Created", "Owner")
        FileInfo = Array(1, 2, 3, 4, 10)
        
        With Rng.Offset(-1, 0).Resize(1, UBound(Headers, 1) + 1)
            .Value = Headers
            .Font.Bold = True
            .Font.Size = 12
        End With
            
            With oShell
                Set Folder = .BrowseForFolder(0&, "Select a Folder", 17&)
                If Folder Is Nothing Then
                    MsgBox "Action Cancelled - Exiting Macro", vbOKOnly + vbInformation
                    Exit Sub
                End If
            End With
            
            Set Files = Folder.Items
                Files.Filter 64, "*.*"
                
                ReDim Data(1 To Files.Count, 1 To UBound(Headers) + 1)
                
                For Each File In Files
                    j = j + 1
                    
                    Data(j, 1) = Folder.Self.Path
                    
                    FileType = Folder.GetDetailsOf(File, 2)
                    n = InStrRev(File, ".")
                    
                    If FileType = "File" Or n = 0 Then
                        Data(j, 2) = File
                    Else
                        Data(j, 2) = Left(File, n - 1)
                        Data(j, 3) = Right(File, Len(File) - n + 1)
                    End If
                    
                    n = 0
                    
                    For k = 4 To UBound(Data, 2)
                        Data(j, k) = Folder.GetDetailsOf(File, FileInfo(n))
                        n = n + 1
                    Next k
                Next File
                
            Set Rng = Rng.Resize(j, UBound(Data, 2))
                Rng.NumberFormat = "general"
                Rng.Columns(2).NumberFormat = "@"
                Rng.Value = Data
                Rng.Columns.AutoFit
            
End Sub

 

[tonyyy]

Very nice, Leith.

Thanks for sharing!

 

[Leith Ross]

Hello tonyyy,

Thanks, glad you like it. Here is another macro to list the index numbers and the detail descriptions. Currently there are about 300 of these. This macro will create the list on the Active Sheet in columns A and B.

Sub ListFileIndicesAndDetails()

  ' Written: July 25, 2016
  ' Author:  Leith Ross
  
    Dim Rng As Range
    Dim Wks As Worksheet
    
        Set Wks = ActiveSheet
        
        Set Rng = Wks.Range("A1:B1")
            Rng.Value = Array("Index", "Detail")
            Rng.Columns(1).EntireColumn.HorizontalAlignment = xlHAlignLeft
        
        With CreateObject("Shell.Application")
            Set Folder = .Namespace(CurDir)
            For n = 0 To 300
                Set Rng = Rng.Offset(1, 0)
                Rng.Cells(1, 1).Value = n
                Rng.Cells(1, 2).Value = Folder.GetDetailsOf(Nothing, n)
            Next n
        End With
        
End Sub

 

[tonyyy]

Way cool, Leith! Definitely filing this away for future reference!

And made note to self to explore Shell.Application.

Thanks much!

 

[Brook70458]

Hey Leith,

Thank you most appreciably. Your approach is exactly what I have had in mind. I especially enjoy you thinking ahead and formatting the columns in the professional manner. I was trying to figure that one too

Now to apply it and teak some more...

Thanks again

 

[Brook70458]

Hi Tonny,

I have been off for a while. I tried your solution and am very impressed. I actually learned about some new coding techniques.

I have a question about another desired feature: Can a column with a url link to the listed file be added,?

I'm assuming the code is in a new workbook and the sheet and cells are unprotected and unhidden.

Let's try fully qualifying the range references...

Sub ListFiles()

'''''  This routine prompts you to select a file, then proceeds
'''''  to list all the files in that directory.

Dim FilePath As String
Dim Directory As String
Dim r As Long
Dim f As String
Dim FileSize As Double
Dim FileExtension As String

FilePath = Application.GetOpenFilename
If FilePath <> "" Then Directory = Left(FilePath, InStrRev(FilePath, "\"))
r = 1

''''  Insert headers
ActiveSheet.Cells(r, 1).Value = "FileName"
ActiveSheet.Cells(r, 2).Value = "Size"
ActiveSheet.Cells(r, 3).Value = "Date / Time"
ActiveSheet.Cells(r, 4).Value = "File Extension"
ActiveSheet.Range("A1:D1").Font.Bold = True

''''  Get first file
f = Dir(Directory, vbReadOnly + vbHidden + vbSystem)
Do While f <> ""
    r = r + 1
    ActiveSheet.Cells(r, 1).Value = f
''''  Adjust for filesize > 2 gigabytes
    FileSize = FileLen(Directory & f)
    If FileSize < 0 Then FileSize = FileSize + 4294967296#
    ActiveSheet.Cells(r, 2).Value = FileSize
    ActiveSheet.Cells(r, 3).Value = FileDateTime(Directory & f)
    FileExtension = Right(f, Len(f) - InStrRev(f, "."))
    ActiveSheet.Cells(r, 4).Value = FileExtension
''''  Get next file
    f = Dir()
Loop
ActiveSheet.Columns.AutoFit
End Sub

 

[McG_84]

Can this code be modified so that once I select the folder, i get all sub-folders and files located within them?

 

[Brook70458]

Hello Brook70458,

While the information you are seeking can be retrieved using the Windows API, it is a lot easier to use the Shell. This is the standard interface used by Windows Explorer when listing files and folders. The code below let's you select the folder whose files you want to list. It will provide the folder path, the file name, the file extension, the file type, the size, the date last modified, the date of creation, and the owner.

The default output is to "Sheet1" starting in cell A1. Row 1 contains the headers. You can change the sheet name in the code if you want the output to a different sheet. Copy the code below and paste it into a new VBA module in your workbook.

Macro to List Files with Meta Data

Sub ListFoldersWithDetails()

    Dim Data        As Variant
    Dim File        As Object
    Dim FileInfo    As Variant
    Dim Files       As Object
    Dim FileType    As String
    Dim Folder      As Object
    Dim Headers     As Variant
    Dim Item        As Variant
    Dim j           As Long
    Dim k           As Long
    Dim n           As Long
    Dim oShell      As Object
    Dim Path        As Variant
    Dim Rng         As Range
    Dim Wks         As Worksheet
    
        Set oShell = CreateObject("Shell.Application")
        
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        Set Rng = Wks.Range("A2")
        
        Headers = Array("Folder", "Name", "Ext.", "Size", "Type", "Date Modified", "Date Created", "Owner")
        FileInfo = Array(1, 2, 3, 4, 10)
        
        With Rng.Offset(-1, 0).Resize(1, UBound(Headers, 1) + 1)
            .Value = Headers
            .Font.Bold = True
            .Font.Size = 12
        End With
            
            With oShell
                Set Folder = .BrowseForFolder(0&, "Select a Folder", 17&)
                If Folder Is Nothing Then
                    MsgBox "Action Cancelled - Exiting Macro", vbOKOnly + vbInformation
                    Exit Sub
                End If
            End With
            
            Set Files = Folder.Items
                Files.Filter 64, "*.*"
                
                ReDim Data(1 To Files.Count, 1 To UBound(Headers) + 1)
                
                For Each File In Files
                    j = j + 1
                    
                    Data(j, 1) = Folder.Self.Path
                    
                    FileType = Folder.GetDetailsOf(File, 2)
                    n = InStrRev(File, ".")
                    
                    If FileType = "File" Or n = 0 Then
                        Data(j, 2) = File
                    Else
                        Data(j, 2) = Left(File, n - 1)
                        Data(j, 3) = Right(File, Len(File) - n + 1)
                    End If
                    
                    n = 0
                    
                    For k = 4 To UBound(Data, 2)
                        Data(j, k) = Folder.GetDetailsOf(File, FileInfo(n))
                        n = n + 1
                    Next k
                Next File
                
            Set Rng = Rng.Resize(j, UBound(Data, 2))
                Rng.NumberFormat = "general"
                Rng.Columns(2).NumberFormat = "@"
                Rng.Value = Data
                Rng.Columns.AutoFit
            
End Sub

Hey Keith,

I had to come back to this project. I lost all of the data in a cyber attack and loss of my HD's.

I was working with this code and found it very robust - thanks. I like the shell solution. It was very fast and compiled a very long list quickly to boot...

How and where would I add two columns, a comment, and a notes, column after name. I would also like the name and extension combined and in the format of a hyperlink to the listed file in the directory.

I would like to upload this file as an ftp index in html format. I would run this tool periodically to update and refresh the ftp index.


Thanks in advance Mate