Consulting

Results 1 to 8 of 8

Thread: Hyperlink to be revised help please

  1. #1
    VBAX Newbie
    Joined
    Oct 2015
    Posts
    3
    Location

    Question Hyperlink to be revised help please

    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.

    wardex.jpg


    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!!

  2. #2
    VBAX Guru mancubus's Avatar
    Joined
    Dec 2010
    Location
    "Where I lay my head is home" :D
    Posts
    2,644
    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
    Last edited by mancubus; 10-28-2015 at 01:41 AM.
    PLS DO NOT PM; OPEN A THREAD INSTEAD!!!

    1) Posting Code
    [CODE]PasteYourCodeHere[/CODE]
    (or paste your code, select it, click # button)

    2) Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific / sensitive / confidential data. Include so many rows and sheets etc in the uploaded workbook to enable the helpers visualize the data and table structure. Helpers do not need the entire workbook.

    3) Testing the Codes
    always back up your files before testing the codes.

    4) Marking the Thread as Solved
    from Thread Tools (on the top right corner, above the first message)

  3. #3
    VBAX Guru mancubus's Avatar
    Joined
    Dec 2010
    Location
    "Where I lay my head is home" :D
    Posts
    2,644
    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.
    Last edited by mancubus; 10-28-2015 at 01:43 AM. Reason: typo
    PLS DO NOT PM; OPEN A THREAD INSTEAD!!!

    1) Posting Code
    [CODE]PasteYourCodeHere[/CODE]
    (or paste your code, select it, click # button)

    2) Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific / sensitive / confidential data. Include so many rows and sheets etc in the uploaded workbook to enable the helpers visualize the data and table structure. Helpers do not need the entire workbook.

    3) Testing the Codes
    always back up your files before testing the codes.

    4) Marking the Thread as Solved
    from Thread Tools (on the top right corner, above the first message)

  4. #4
    VBAX Newbie
    Joined
    Oct 2015
    Posts
    3
    Location
    OMG thanks a lot. I'll try your recommendation

  5. #5
    VBAX Guru mancubus's Avatar
    Joined
    Dec 2010
    Location
    "Where I lay my head is home" :D
    Posts
    2,644
    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)
    PLS DO NOT PM; OPEN A THREAD INSTEAD!!!

    1) Posting Code
    [CODE]PasteYourCodeHere[/CODE]
    (or paste your code, select it, click # button)

    2) Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific / sensitive / confidential data. Include so many rows and sheets etc in the uploaded workbook to enable the helpers visualize the data and table structure. Helpers do not need the entire workbook.

    3) Testing the Codes
    always back up your files before testing the codes.

    4) Marking the Thread as Solved
    from Thread Tools (on the top right corner, above the first message)

  6. #6
    VBAX Newbie
    Joined
    Jan 2017
    Posts
    1
    Location
    This worked great for me, thank you
    How could I add a second column containing the creation date of the file?

  7. #7
    VBAX Guru mancubus's Avatar
    Joined
    Dec 2010
    Location
    "Where I lay my head is home" :D
    Posts
    2,644
    welcome to the forum.

    add the following line in the loop:
    PHP Code:
                .Cells(i2) = FileDateTime(.Cells(i1)) 
    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
    PLS DO NOT PM; OPEN A THREAD INSTEAD!!!

    1) Posting Code
    [CODE]PasteYourCodeHere[/CODE]
    (or paste your code, select it, click # button)

    2) Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific / sensitive / confidential data. Include so many rows and sheets etc in the uploaded workbook to enable the helpers visualize the data and table structure. Helpers do not need the entire workbook.

    3) Testing the Codes
    always back up your files before testing the codes.

    4) Marking the Thread as Solved
    from Thread Tools (on the top right corner, above the first message)

  8. #8
    VBAX Newbie
    Joined
    Jan 2017
    Posts
    1
    Location
    Great stuff, thanks mancubus.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •