Addition to previous code by Ken Puls

ey67

New member
Joined
Jan 10, 2013
Messages
2
Reaction score
0
Points
0
Hi everyone,

I am very very new to VBA and found code by Ken here: http://www.vbaexpress.com/kb/getarticle.php?kb_id=232. It does a fantastic job of listing the files inside a folder but I was wondering if it would be possible to include files inside of a subfolder in the initially selected directory.


Any help or guidance would be greatly appreciated!

ey67
 

Ken Puls

Administrator
Staff member
Joined
Mar 13, 2011
Messages
2,520
Reaction score
5
Points
38
Location
Nanaimo, BC, Canada
Website
www.excelguru.ca
Excel Version(s)
Excel Office 365 Insider
Something like this:

Code:
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
    Call ListFiles(subfolder)
    For Each subfolder In fso.GetFolder(Directory).subfolders
        Call ListFiles(subfolder.Files)
    Next subfolder
     
End Sub
Sub ListFiles(subfolder As Object)
    Dim file As Object
    
    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("A" & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0), _
                    Address:=file.Path, _
                    TextToDisplay:=file.Path & "\" & file.Name
                Else 'Using XL97
                    .Hyperlinks.Add _
                    Anchor:=ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0), _
                    Address:=file.Path & "\" & file.Path
                End If
                 'Add date last modified, and size in KB
                With .Range("A" & ActiveSheet.Rows.Count).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
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
 

ey67

New member
Joined
Jan 10, 2013
Messages
2
Reaction score
0
Points
0
Hi Ken,

That is fantastic! Thank you very much, I've added a few things to this to make it work but would not have been able to get it to work on my own.

Cheers,
ey67
 
Top