Hyperlink List of Files in Folder

[erock24]

I found the following code that creates a hyperlinked list of all files in a folder. How can the code be edited to also bring back properties of the file. I would like to see dates: created, last modified, last accessed.

Sub HyperlinkXLSFiles()
Dim lCount As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next

    With Application.FileSearch
        .NewSearch
         'Change path to suit
        .LookIn = "C:\MyDocuments\Testings"
        .FileType = msoFileTypeExcelWorkbooks
       ' .Filename = "Book*.xls"
        
            If .Execute > 0 Then 'Workbooks in folder
                For lCount = 1 To .FoundFiles.Count 'Loop through all.
                    ActiveSheet.Hyperlinks.Add Anchor:=Cells(lCount, 1), Address:= _
                    .FoundFiles(lCount), TextToDisplay:= _
                     Replace(.FoundFiles(lCount), "C:\MyDocuments\Testings\", "")
                 Next lCount
            End If
    End With
    
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

 

[pbornemeier]

See: http://www.mrexcel.com/forum/showthread.php?t=329797

 

[erock24]

That is previous thread of mine. It is not a hyperlinked list however. I need a macro that can list all the files of a folder and the files date properties and the list needs to be hyperlinked.

Thank you.

 

[Kath]

Hello erock24. *Bumps thread* I see you are an active member here & was trying to send this while you were online just now but missed you!

You may have seen I have an identical requirement in my thread http://www.mrexcel.com/forum/showthread.php?t=341608&highlight=hyperlinked

though I don't need the detailed date properties. I'm really surprised this doesn't come up more often - eg name, rank, number...photo! I suppose the assumption is that a full-on database is required.

Have you had any luck with this? kgkev solved mine, but without using code (phew, as I have no idea about code). There is still some manual intervention required, so as a user I'd love to see a macro/code solution without needing to understand how it is done behind the scenes.

The dos code:

dir C:\Testimages /T:A >C:\Testimageslist.xls

would give you the unhyperlinked list of file names and - in this example - access dates in an Excel spreadsheet (and some other junk you'd need to edit out), but I could only get creation date [/T:C] and modified date [/T:W] as alternatives rather than outputting all three together.

You could then bulk hyperlink them using kgkev's method.

So there is a non-code way to do it, but laborious and not justified unless you have millions of files (like I do!).

Anyway, interested to hear if there's any news on this!

 

[erock24]

Well, I received the following code that will search a folder and create a hyperlinked list of all it's contents with some file attributes as well. I tweaked it a little to also bring back specific cell data on the sheets.

Sub MISCFile_Listing()
'Standard module code, like: Module1.
Dim objFileScript As Object, objFolder As Object, objThisFile As Object, objThisFolder
Dim strFileCreate$, strFileAccess$, strFileDtMod$, strAttrNm$
Dim strFileNm$, strFileType$, strFileAttr$, strFilePath$
Dim dubFileSize#
Dim lngAttr&

'strFolderNm = CurDir
On Error Resume Next
Columns("B:C").Columns.Ungroup
ActiveSheet.Cells.Delete

ActiveSheet.Range("A4").Value = "Folder"
ActiveSheet.Range("b4").Value = "Name.Ext"
ActiveSheet.Range("c4").Value = "Author"
ActiveSheet.Range("d4").Value = "Lines"
ActiveSheet.Range("e4").Value = "Amount"
ActiveSheet.Range("f4").Value = "Year"
ActiveSheet.Range("g4").Value = "Create Date"
ActiveSheet.Range("H4").Value = "Last Modified"
ActiveSheet.Range("I4").Value = "Size"
ActiveSheet.Range("J4").Value = "Units"
ActiveSheet.Range("K4").Value = "Type"
ActiveSheet.Range("L4").Value = "Attribute"
ActiveSheet.Range("A4:L4").Font.Bold = True
 
Set objFileScript = CreateObject("Scripting.FileSystemObject")
'Change Path as Needed
Set objFolder = objFileScript.GetFolder("Y:\Budget\2009\Manual Sheets\Manual Sheets\Plant Projects & MISC\Posted")
Set objThisFolder = objFolder.Files
 
For Each objThisFile In objThisFolder
strFilePath = objThisFile.Path
strFileNm = objThisFile.Name
dubFileSize = objThisFile.Size
strFileType = objThisFile.Type
strFileCreate = objThisFile.DateCreated
strFileAccess = objThisFile.DateLastAccessed
strFileDtMod = objThisFile.DateLastModified
strAttrNm = ""
lngAttr = 0
lngAttr = objThisFile.Attributes
 
If lngAttr = 0 Then
strAttrNm = strAttrNm & "Normal"
ElseIf lngAttr = 16 Then
strAttrNm = strAttrNm & "Directory "
ElseIf lngAttr = 1 Then
strAttrNm = strAttrNm & "Read-Only "
ElseIf lngAttr = 2 Then
strAttrNm = strAttrNm & "Hidden "
ElseIf lngAttr = 4 Then
strAttrNm = strAttrNm & "Normal System "
ElseIf lngAttr = 8 Then
strAttrNm = strAttrNm & "Volume "
ElseIf lngAttr = 32 Then
strAttrNm = strAttrNm & "Archive "
ElseIf lngAttr = 1024 Then
strAttrNm = strAttrNm & "Alias "
ElseIf lngAttr = 2048 Then
strAttrNm = strAttrNm & "Compressed "
Else

strAttrNm = strAttrNm & "Hidden System "
End If
 
strFileAttr = strAttrNm
ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
Selection.Value = strFilePath
Selection.Offset(0, 1).Value = strFileNm
Selection.Offset(0, 2).Formula = "='" _
    & Left(strFilePath, InStrRev(strFilePath, Application.PathSeparator)) _
    & "[" & strFileNm & "]BUDGET'!$N$2"
Selection.Offset(0, 3).Formula = "='" _
    & Left(strFilePath, InStrRev(strFilePath, Application.PathSeparator)) _
    & "[" & strFileNm & "]BUDGET'!$C$2"
Selection.Offset(0, 4).Formula = "='" _
    & Left(strFilePath, InStrRev(strFilePath, Application.PathSeparator)) _
    & "[" & strFileNm & "]BUDGET'!$V$3"
Selection.Offset(0, 5).Formula = "='" _
    & Left(strFilePath, InStrRev(strFilePath, Application.PathSeparator)) _
    & "[" & strFileNm & "]BUDGET'!$C$3"
Selection.Offset(0, 6).Value = strFileCreate
Selection.Offset(0, 7).Value = strFileDtMod
Selection.Offset(0, 8).Value = Format(dubFileSize, "###,###,###")
Selection.Offset(0, 9).Value = " Bytes"
Selection.Offset(0, 10).Value = strFileType
Selection.Offset(0, 11).Value = strFileAttr
On Error Resume Next
Next objThisFile
Columns("A:m").Columns.AutoFit
Columns("A:A").Insert Shift:=xlToRight
Range("A4").FormulaR1C1 = "File Name - Link"
Range("A4").Font.Bold = True
Range("A5").FormulaR1C1 = "=HYPERLINK(RC2,RC3)"
On Error Resume Next
Range("A5").AutoFill Destination:=Range("A5:A" & Range("B" & Rows.Count).End(xlUp).Row), Type:=xlFillDefault
 Columns("B:C").Columns.Group
 ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
With ActiveSheet.Range("A1")
.Value = "Posted Manual Sheet Inventory - Plant Projects & MISC"
.Font.Bold = True
End With
With ActiveSheet.Range("A2")
.FormulaR1C1 = "As of " & Date
.Font.Bold = True
End With
Columns("A:A").Columns.AutoFit
With Range("A4:M4")
    .Borders(xlEdgeTop).LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlDouble
End With
With Columns("D:G")
    .Value = .Value
End With
Columns("F:F").NumberFormat = "#,##0_);[Red](#,##0)"
Columns("E:E").HorizontalAlignment = xlCenter
Columns("G:G").NumberFormat = "0_);(0)"
Columns("H:I").NumberFormat = "mm/dd/yy;@"
Columns("J:J").NumberFormat = "#,##0_);[Red](#,##0)"
Dim rng2 As Range
Dim lastrow As Long
Dim cc As Range
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set rng2 = Range(Cells(5, 4), Cells(lastrow, 7))
For Each cc In rng2
If cc.Value = "#REF!" Or cc.Value = "0" Then cc.Value = ""
Next cc
    
Application.Goto reference:="R1C1"
MsgBox ("MISC Inventory Complete")
End Sub

 

[Kath]

Woah thanks for the speedy reply, erock24!

Give me a while to see how to use it & what it does, and I'll report back accordingly!