Hyperlinked List of Directory Contents

[Ken Puls]

I received this question via PM:

Hi Ken,

I'm new to VB (having only created macros with excel's help in the past) and have found your 'Create Hyperlinked List of Directory Contents' script very interesting. I'm trying to develop a way I can 'update' an excel doc with hyperlinks to new documents which I've added without the need to perform the painstaking task manually which I've been doing up to date. All my attempts were failing until your helpful piece of script! Which returned the required info and created the link - excellent.

What I'm now trying to do is 'include all sub directories' but I must admit I seem to be failing miserably at modifying the script! Could you give me some pointers please?

Many thanks once again for your help already!

Lee

The KB entry that Lee is referring to is this one.

Unfortunately I don't have time to craft a reply, and probably won't be able to for a couple of days. Anyone want to tackle this?

[Bob Phillips]

My alternative

[vba]

Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "C:\test"
ReDim arfiles(2, 0)
If sFolder <> "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = arPath(level - 1)
arfiles(2, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
For Each oFile In oFiles
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = oFile.Name
arfiles(2, cnt) = level + 1
Next oFile

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub
[/vba]

[JKwan]

You can also try this:
http://www.cpearson.com/excel/RecursionAndFSO.htm

[Ken Puls]

Fwiw, Lee did PM me back to say that he/she had seen this thread and was going to try the posted solution. I can only assume that it worked. Thanks, Bob!

JKwan, thanks as well. I hadn't seen that page on Chip's site.

[ahdad]

Dear Ken,
How can this code be modified so as to list the new contents of the same folder and not add a second copy of the contents, once its run again after a few days ? This is important as I don't want to create a new list and delete the old one, but rather modify the existing one by adding/deleting entries according to the folder's contents.

I'm not sure if this question seems trivial; unfortunately I have no programming knowledge of VBA. I only program in C++ and used to program in BASIC (if anyone still remembers that ).