Results 1 to 3 of 3

Thread: Addition to previous code by Ken Puls

  1. #1

    Addition to previous code by Ken Puls



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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

  2. #2
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,243
    Articles
    57
    Blog Entries
    14
    Excel Version
    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
    Ken Puls, FCPA, FCMA, MS MVP (Excel)

    Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training) or with my book M is for Data Monkey!

    Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
    Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter

    If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.

  3. #3
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •