PDA

View Full Version : Hyperlink to be revised help please



wardex
10-27-2015, 10:59 PM
I found a useful code which automatically creates hyperlinks of files in a folder. My problem is that I want the code to also create Hyperlinks of the sub folder within a folder and not its content inside.

14664


This code needs to be revised. It only creates hyperlinks of files within a folder and files in a sub folder within a folder.

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, _
Folder 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






I hope someone can help me with this. I need this for my reports. Thanks a lot!!

mancubus
10-28-2015, 01:02 AM
thanks to snb and Kenneth Hobs for my part...

no header row is assumed. if there is a header row, modify the code to suit.



Sub vbax_54127_List_Files_Create_Hyperlinks()
Dim ParentFolderName As String
Dim ArrFiles
Dim i As Long

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath
.Title = "Please select a folder!"
.AllowMultiSelect = False
If .Show = -1 Then
ParentFolderName = .SelectedItems(1) & "\"
Else
MsgBox "You pressed Cancel. Quitting...", vbCritical, "Cancelled"
Exit Sub
End If
End With
'or
'ParentFolderName = "C:\MyParentFolder\" 'change to suit

ArrFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir """ & ParentFolderName & "*.*"" /b/s").StdOut.ReadAll, vbCrLf)

With Worksheets("Sheet1") 'Change Sheet1 to suit
.Cells(1).CurrentRegion.Clear
.Cells(1).Resize(UBound(ArrFiles)) = Application.Transpose(ArrFiles)
'For i = 0 To UBound(ArrFiles) - 1
For i = 1 To UBound(ArrFiles)
.Cells(i, 1).Hyperlinks.Add _
Anchor:=.Cells(i, 1), _
Address:=.Cells(i, 1), _
TextToDisplay:=CreateObject("Scripting.FileSystemObject").GetBaseName(.Cells(i, 1))
Next i
End With

End Sub

mancubus
10-28-2015, 01:07 AM
if the file names contain, lets say, non-english characters, use below



Sub vbax_54127_List_Files_Create_Hyperlinks()
Dim tempStr As String, ParentFolderName As String
Dim ArrFiles
Dim i As Long

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath
.Title = "Please select a folder!"
.AllowMultiSelect = False
If .Show = -1 Then
ParentFolderName = .SelectedItems(1) & "\"
Else
MsgBox "You pressed Cancel. Quitting...", vbCritical, "Cancelled"
Exit Sub
End If
End With
'or
'ParentFolderName = "C:\MyParentFolder\" 'change to suit

ArrFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir """ & ParentFolderName & "*.*"" /b/s").StdOut.ReadAll, vbCrLf)

For i = LBound(ArrFiles) To UBound(ArrFiles)
tempStr = ArrFiles(i)
tempStr = StripAccent(tempStr)
ArrFiles(i) = tempStr
Next i

With Worksheets("Sheet1") 'Change Sheet1 to suit
.Cells(1).CurrentRegion.Clear
.Cells(1).Resize(UBound(ArrFiles)) = Application.Transpose(ArrFiles)
'For i = 0 To UBound(ArrFiles) - 1
For i = 1 To UBound(ArrFiles)
.Cells(i, 1).Hyperlinks.Add _
Anchor:=.Cells(i, 1), _
Address:=.Cells(i, 1), _
TextToDisplay:=CreateObject("Scripting.FileSystemObject").GetBaseName(.Cells(i, 1))
Next i
End With

End Sub


with the following UDF



Function StripAccent(thestring As String)
'http://www.extendoffice.com/documents/excel/707-excel-replace-accented-characters.html
Dim A As String * 1
Dim B As String * 1
Dim i As Integer

Const AccChars = "ŠZšzŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏ?ÑÒÓÔÕÖÙÚÛÜYàáâãäåçèéêëìíîï?ñòóôõöùúûüyÿ"
Const RegChars = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"

For i = 1 To Len(AccChars)
A = Mid(AccChars, i, 1)
B = Mid(RegChars, i, 1)
thestring = Replace(thestring, A, B)
Next

StripAccent = thestring
End Function



replace AccChars, "ŠZšzŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏ?ÑÒÓÔÕÖÙÚÛÜYàáâãäåçèéêëìíîï?ñòóôõöùúûüyÿ", with your local accented characters
and RegChars, "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy", with their regular (or English) equivalents.

PS: they must be in the same orser.

wardex
10-28-2015, 01:23 AM
OMG thanks a lot. I'll try your recommendation :)

mancubus
10-28-2015, 01:40 AM
you are welcome.

possibly you are looking for excel files. if so;

change


ArrFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir """ & ParentFolderName & "*.*"" /b/s").StdOut.ReadAll, vbCrLf)


to


ArrFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir """ & ParentFolderName & "*.xl??"" /b/s").StdOut.ReadAll, vbCrLf)

Andym6
01-21-2017, 05:32 AM
This worked great for me, thank you :)
How could I add a second column containing the creation date of the file?

mancubus
01-21-2017, 03:53 PM
welcome to the forum.

add the following line in the loop:

.Cells(i, 2) = FileDateTime(.Cells(i, 1))



Sub vbax_54127_List_Files_Create_Hyperlinks()

Dim tempStr As String, ParentFolderName As String
Dim ArrFiles
Dim i As Long

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath
.Title = "Please select a folder!"
.AllowMultiSelect = False
If .Show = -1 Then
ParentFolderName = .SelectedItems(1) & "\"
Else
MsgBox "You pressed Cancel. Quitting...", vbCritical, "Cancelled"
Exit Sub
End If
End With
'or
'ParentFolderName = "C:\MyParentFolder\" 'change to suit

ArrFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir """ & ParentFolderName & "*.*"" /b/s").StdOut.ReadAll, vbCrLf)

With Worksheets("Sheet1") 'Change Sheet1 to suit
.Cells(1).CurrentRegion.Clear
.Cells(1).Resize(UBound(ArrFiles)) = Application.Transpose(ArrFiles)
For i = 1 To UBound(ArrFiles)
.Cells(i, 2) = FileDateTime(.Cells(i, 1))
.Cells(i, 1).Hyperlinks.Add _
Anchor:=.Cells(i, 1), _
Address:=.Cells(i, 1), _
TextToDisplay:=CreateObject("Scripting.FileSystemObject").GetBaseName(.Cells(i, 1))
Next i
End With

End Sub

Jacksonb
01-21-2017, 11:53 PM
Great stuff, thanks mancubus.