PDA

View Full Version : Help with Create Hyperlinked List of Directory Contents



Ken D
06-02-2010, 09:01 AM
I pretty much found exactly what I was looking for here from Ken Puls Create Hyperlinked List of Directory Contents script. The problem I am having is that is is not creating the hyperlinks of files in subfolders. Is there a way to do this? (please excuse me for being a complete newbie) here is a copy of the code:



Option Compare Text
Option Explicit

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

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
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("A65536").End(xlUp).Offset(1, 0), _
Address:=File.path, _
TextToDisplay:=File.Name
Else 'Using XL97
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.path
End If
'Add date last modified, and size in KB
With .Range("A65536").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

lynnnow
06-02-2010, 09:24 AM
Take a look at this http://www.vbaexpress.com/kb/getarticle.php?kb_id=800

Bob Phillips
06-02-2010, 09:36 AM
Dim FSO As Object
Dim cnt As Long
Dim arfiles
Dim level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String

Set FSO = CreateObject("Scripting.FileSystemObject")

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

sFolder = "C:\myTest"
ReDim arfiles(1, 0)
If sFolder <> "" Then
SelectFiles sFolder
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(1, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(0, i)
Next
.Columns("A:Z").EntireColumn.AutoFit
End With
End If

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Dim fldr As Object
Dim Folder As Object
Dim file As Object
Dim Files As Object

If sPath = "" Then
Set FSO = CreateObject("SCripting.FileSystemObject")
sPath = "c:\myTest"
End If

Set Folder = FSO.GetFolder(sPath)

Set Files = Folder.Files
For Each file In Files
cnt = cnt + 1
ReDim Preserve arfiles(1, cnt)
arfiles(0, cnt) = Folder.path & "\" & file.Name
arfiles(1, cnt) = level
Next file

level = level + 1
For Each fldr In Folder.Subfolders
SelectFiles fldr.path
Next

End Sub

Ken D
06-02-2010, 02:12 PM
Plz Additional help.... I am have problem run both suggestions with 1st reply it is erroring out on

Set Folder = FSO.GetFolder(sPath)

and on the second reply I am erroring out on

With Application.FileSearch

I am using excel 2007.