Macro to create list of hyperlinks to all files in chosen folder including subfolders

[1819]

This code works well to create a list of hyperlinks to files but it is limited to hardcoded folders and does not include subfolders.

Please could you propose how it could be amended:

1) to allow the user to select the folder by browsing
2) to include the option of including subfolders, maintaining the folder structure in the resulting list of hyperlinks.

Many thanks.



Option Explicit

Sub CreateListofFileswithHyperlinks()

Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")

'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\Whatever")
i = 1

'loops through each file in the directory
For Each objFile In objFolder.Files
'select cell
Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select
'create hyperlink in selected cell
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
objFile.Path, _
TextToDisplay:=objFile.Name
i = i + 1
Next objFile
End Sub

[Fennek]

Hi,

first of all: the following codes are copy/paste from the internet and NOT testet, it would be just a surprise, if no debugging is necessary:



Sub GetFileNames()

Dim xRow As Long
Dim xDirect, xFname$, InitialFoldr$

InitialFoldr$ = "G:\" '<<< Startup folder to begin searching from

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
sn = Split(CreateObject("wscript.shell").exec("cmd /c dir " & xDirect & "/b/s").stdout.readall, vbCrLf)
i=2
For Each d In sn
cells(i, "A") = d
i=i+1
cells(i,"A").hyperlinks.add d
Next d
end if
End With
End Sub


regards

[1819]

Thank you Fennek. I am unable to test this today owing to the New Year holiday but will do so as soon as possible.

Thanks again.

[1819]

As you thought Fennek, the code was a bit buggy, so I used lines of your code to search. I came across this one which seems to work:



Option Explicit

Public FSO As New FileSystemObject
Private FileType As Variant


Sub ListHyperlinkFilesInSubFolders()

' Written by Philip Treacy, http://www.myonlinetraininghub.com/author/philipt
' My Online Training Hub http://www.myonlinetraininghub.com/Create-Hyperlinked-List-of-Files-in-Subfolders
' May 2014

Dim StartingCell As String 'Cell where hyperlinked list starts
Dim FSOFolder As Folder
Dim RootFolder As String

Application.ScreenUpdating = False

'Make this a cell address to insert list at fixed cell
'e.g. StartingCell = "A1"
StartingCell = ActiveCell.Address


'Ask for folder to list files from
With Application.FileDialog(msoFileDialogFolderPicker)

.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select folder to list files from"
.Show

'If a folder has been selected
If .SelectedItems.Count <> 0 Then

RootFolder = .SelectedItems(1)

Set FSOFolder = FSO.GetFolder(RootFolder)

'Ask what type of files to look for
FileType = Application.InputBox("* and ? wildcards are valid " & vbCrLf & vbCrLf & " e.g. .xls* to list XLS, XLSX and XLSM" _
& vbCrLf & vbCrLf & "??st.* to list West.xlsx and East.xlsx" & vbCrLf & vbCrLf & "Just click OK to list all files.", _
"What type of files do you want to list?", "")

If FileType = False Then 'Cancel pressed

MsgBox "Process Cancelled"
Exit Sub

ElseIf FileType = vbNullString Then 'Nothing entered and OK pressed

FileType = "*.*"

End If

'Clear the active sheet to remove previous results
ActiveSheet.Cells.Clear

'Enter default message in case no files are in folder
With Range(StartingCell).Offset(1)

.ClearFormats
.Value = "No " & FileType & " files found in " & RootFolder
.Select

End With

' Call recursive sub to list files
ListFilesInSubFolders FSOFolder, ActiveCell

'Autofit the columns containing our results
Columns.AutoFit

Else

'If no folder selected, admonish user for wasting CPU cycles :)
MsgBox "No folder selected.", vbExclamation

End If

End With

Application.ScreenUpdating = True

End Sub



Sub ListFilesInSubFolders(StartingFolder As Scripting.Folder, DestinationRange As Range)
' Written by Philip Treacy, http://www.myonlinetraininghub.com/author/philipt
' My Online Training Hub http://www.myonlinetraininghub.com/Create-Hyperlinked-List-of-Files-in-Subfolders
' May 2014
' Lists all files specified by FileType in all subfolders of the StartingFolder object.
' This sub is called recursively

Dim CurrentFilename As String
Dim OffsetRow As Long
Dim TargetFiles As String
Dim SubFolder As Scripting.Folder

'Write name of folder to cell
DestinationRange.Value = StartingFolder.Path

'Get the first file, look for Normal, Read Only, System and Hidden files
TargetFiles = StartingFolder.Path & "\" & FileType

CurrentFilename = Dir(TargetFiles, 7)

OffsetRow = 1

Do While CurrentFilename <> ""

'Create the hyperlink
DestinationRange.Offset(OffsetRow).Hyperlinks.Add Anchor:=DestinationRange.Offset(OffsetRow), Address:=StartingFolder.Path & "\" & CurrentFilename, TextToDisplay:=CurrentFilename

OffsetRow = OffsetRow + 1

'Get the next file
CurrentFilename = Dir

Loop


' Offset the DestinationRange one column to the right and OffsetRows down so that we start listing files
' inthe next folder below where we just finished. This results in an indented view of the folder structure
Set DestinationRange = DestinationRange.Offset(OffsetRow, 1)

' For each SubFolder in the current StartingFolder call ListFilesInSubFolders (recursive)
' The sub continues to call itself for each and every folder it finds until it has
' traversed all folders below the original StartingFolder
For Each SubFolder In StartingFolder.SubFolders

ListFilesInSubFolders SubFolder, DestinationRange

Next SubFolder

' Once all files in SubFolder are listed, move the DestinationRange down 1 row and left 1 column.
' This gives a clear visual structure to the listing showing that we are done with the current SubFolder
' and moving on to the next SubFolder
Set DestinationRange = DestinationRange.Offset(1, -1)
DestinationRange.Select

End Sub

[Fennek]

Hello,

after a little test:



Sub GetFileNames()

Dim xRow As Long
Dim xDirect, xFname$, InitialFoldr$

InitialFoldr$ = "C:\" '<<< Startup folder to begin searching from

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
sn = Split(CreateObject("wscript.shell").exec("cmd /c dir " & xDirect & "/b/s").stdout.readall, vbCrLf)
i=2
For Each d In sn
activesheet.hyperlinks.add cells(i, "A"), d
i=i+1
Next d
End If
End With
End Sub


regards

[snb]

This will do:


Sub M_snb()
With Application.FileDialog(4)
If .Show Then sn = Split(CreateObject("wscript.shell").exec("cmd /c dir """ & .SelectedItems(1) & "\*.*"" /a-d /b /s").stdout.readall, vbCrLf)
End With

For Each it In sn
ActiveSheet.Hyperlinks.Add Cells(Rows.Count, 1).End(xlUp).Offset(1), it
Next
End Sub

[1819]

Thank you both, Fennek and snb.

I'm getting "Variable not defined" each time "sn" is used in both your macros:


sn = Split(CreateObject("wscript.shell").exec("cmd /c dir " & xDirect & "/b/s").stdout.readall, vbCrLf)

and


If .Show Then sn = Split(CreateObject("wscript.shell").exec("cmd /c dir """ & .SelectedItems(1) & "\*.*"" /a-d /b /s").stdout.readall, vbCrLf)

Any ideas as to how to fix this? Thanks.

[Fennek]

Hallo,

just delete "option explicit". In most cases it is not necessary and at least for me, it is easyer.

regards

[1819]

Hallo,

just delete "option explicit". In most cases it is not necessary and at least for me, it is easyer.

regards

That's worked, thank you.