Text Functions‎ > ‎

Directory Listing

SITUATION:
"I'd like to be able to get a quick 'list' of all the files in a directory along with hyperlinks for opening them if needed."

SPECIFICATIONS:
  1. User can pick any folder
  2. User can specify which file type they want to get a listing of, or use * for all
  3. Option to turn the list created into a hyperlinked directory to open listed files
  4. Show the last modified time of each file in created listing


CODE

Option Explicit

Sub HyperlinkDirectory()
'Author:    Jerry Beaucaire, ExcelForum.com
'Date:      10/8/2010
'Summary:   User selects a folder and file type, macro returns
'           a complete listing of all files matching that type
'           with a hyperlink to the file for ease of opening
Dim fPath As String
Dim fType As String
Dim fname As String
Dim NR As Long
Dim AddLinks As Boolean

'Select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = "C:\2009\"
        .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With

'Types of files
    fType = Application.InputBox("What kind of files? Type the file extension to collect" _
            & vbLf & vbLf & "(Example:  pdf, doc, txt, xls, *)", "File Type", "pdf", Type:=2)
    If fType = "False" Then Exit Sub
   
'Option to create hyperlinks
    AddLinks = MsgBox("Add hyperlinks to the file listing?", vbYesNo) = vbYes
   
'Create report
    Application.ScreenUpdating = False
    NR = 5
    With Sheets("Sheet1")
        .Range("A:C").Clear
        .[A1] = "Directory"
        .[B1] = fPath
        .[A2] = "File type"
        .[B2] = fType
        .[A4] = "File"
        .[B4] = "Modified"
       
        fname = Dir(fPath & "*." & fType)
       
        Do While Len(fname) > 0
          'filename
            .Range("A" & NR) = fname
          'modified
            .Range("B" & NR) = FileDateTime(fPath & fname)
          'hyperlink
            If AddLinks Then .Hyperlinks.Add Anchor:=Range("A" & NR), _
                Address:=fPath & fname, _
                TextToDisplay:=fPath & fname
          'set for next entry
            NR = NR + 1
            fname = Dir
        Loop
       
        .Range("A:B").Columns.AutoFit
    End With
   
    Application.ScreenUpdating = True
End Sub




Nothing says "thanks" like a steak dinner!
PayPal - The safer, easier way to pay online!
Comments