February | 2025 | Dream come true

De VBA code genereert een lijst met bestanden in een map. Je kunt zelf een map (directory) kiezen waarvan je de bestanden wil zien.

Voorbeeld weergave:

Voeg onderstaande code toe:

1. Kopieer de onderstaande code middels Ctrl + C
2. Druk op de toetscombinatie ALT + F11 om de Visual Basic Editor te openen
3. Druk op de toetscombinatie ALT + N om het menu Invoegen te openen
4. Druk op M om een standaard module in te voegen
5. Daar waar de cursor knippert voeg je de code in middels Ctrl + V
6. Druk op de toetscombinatie ALT + Q om terug te keren naar het Excel werkblad
7. Tenslotte ga naar View | Macros | View macros en kies je de juiste macro.

Option Compare Text
Option Explicit

Function Excludes(Ext As String) As Boolean
Dim X, NumPos As Long
    'Function purpose:  To exclude listed file extensions from hyperlink listing
    
    '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
Dim SubFolder As Object, Directory As String
Dim 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
            
            'Using XL2000+
            If Val(Application.Version) > 8 Then
                .Parent.Hyperlinks.Add Anchor:=.Offset(0, 1), _
                    Address:=Directory, TextToDisplay:=Directory
            
            'Using XL97
            Else
                .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
                
                'Using XL2000+
                If Val(Application.Version) > 8 Then
                    .Hyperlinks.Add _
                        Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, _
                        0), Address:=File.path, _
                        TextToDisplay:=File.Name
                
                'Using XL97
                Else
                    .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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

Option Compare Text

Option Explicit

Function Excludes(Ext As String) As Boolean

Dim X, NumPos As Long

'Function purpose: To exclude listed file extensions from hyperlink listing

'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

Dim SubFolder As Object, Directory As String

Dim 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

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

'Using XL2000+

If Val(Application.Version) > 8 Then

.Parent.Hyperlinks.Add Anchor:=.Offset(0, 1), _

Address:=Directory, TextToDisplay:=Directory

'Using XL97

Else

.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

'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

'Using XL2000+

If Val(Application.Version) > 8 Then

.Hyperlinks.Add _

Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, _

0), Address:=File.path, _

TextToDisplay:=File.Name

'Using XL97

Else

.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 If

End Sub

Dream come true

https://whydonate.com/en/fundraising/cafe-restoration-project

Monthly Archives: February 2025

Bestanden in map tonen met hyperlinks

Unieke lijst genereren