Lijst met files aanmaken van een bepaalde folder in Excel 2007

[AABE]

Geacht forum,

ik heb een mooie vba code gevonden welke een lijst van bestanden (met een link er naar toe) produceert van een bepaalde folder inclusief subfolder.
Dit werkt perfect in Excel 2003 maar ik krijg een foutmelding in Excel 2007.

Bij With Application.FileSearch krijg ik error 445.


Weten jullie een oplossing?

Ik hoor het graag.

mvg,

Aat

Sub SrchForFiles()
     ' Searches the selected folders and sub folders for files with the specified
     'extension.  .xls, .doc, .ppt, etc.
     'A new worksheet is produced called "File Search Results".  You can click on the link and go directly
     'to the file you need.
    Dim i As Long, z As Long, Rw As Long
    Dim ws As Worksheet
    Dim y As Variant
    Dim fLdr As String, Fil As String, FPath As String
     
    y = Application.InputBox("Please Enter File Extension", "Info Request")
    If y = False And Not TypeName(y) = "String" Then Exit Sub
    Application.ScreenUpdating = False
     '**********************************************************************
     'fLdr = BrowseForFolderShell
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        fLdr = .SelectedItems(1)
    End With
     '**********************************************************************
    With Application.FileSearch
        .NewSearch
        .LookIn = fLdr
        .SearchSubFolders = True
        .Filename = y
        Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
        On Error GoTo 1
2:                      ws.Name = "FileSearch Results"
        On Error GoTo 0
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                Fil = .FoundFiles(i)
                 'Get file path from file name
                FPath = Left(Fil, Len(Fil) - Len(Split(Fil, "\")(UBound(Split(Fil, "\")))) - 1)
                If Left$(Fil, 1) = Left$(fLdr, 1) Then
                    If CBool(Len(Dir(Fil))) Then
                        z = z + 1
                        ws.Cells(z + 1, 1).Resize(, 4) = _
                        Array(Dir(Fil), _
                        FileLen(Fil) / 1000, _
                        FileDateTime(Fil), _
                        FPath)
                        ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _
                        Address:=.FoundFiles(i)
                    End If
                End If
            Next i
        End If
    End With
     
    ActiveWindow.DisplayHeadings = False
     
    With ws
        Rw = .Cells.Rows.Count
        With .[A1:D1]
            .Value = [{"Full Name","Kilobytes","Last Modified", "Path"}]
            .Font.Underline = xlUnderlineStyleSingle
            .EntireColumn.AutoFit
            .HorizontalAlignment = xlCenter
        End With
        .[E1:IV1 ].EntireColumn.Hidden = True
        On Error Resume Next
        Range(Cells(Rw, "A").End(3)(2), Cells(Rw, "A")).EntireRow.Hidden = True
        Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], xlAscending, Header:=xlNo
    End With
     
    Application.ScreenUpdating = True
    Exit Sub
1:          Application.DisplayAlerts = False
    Worksheets("FileSearch Results").Delete
    Application.DisplayAlerts = True
    GoTo 2
End Sub

 

[geep1980]

probeer het eens met de volgende code(s)

Sub A()
Dim FSO As Object
Dim wb As Workbook
Dim sLook() As String, vLook As Variant
Dim fName As String

y = Application.InputBox("Please Enter File Extension", "Info Request")
    If y = False And Not TypeName(y) = "String" Then Exit Sub


ReDim sLook(1 To 2) As String 'change the slook to suit the number of different locations
sLook(1) = "C:\Apps"
'sLook(2) = "C:\Apps\Test\"

Set FSO = CreateObject("Scripting.FilesystemObject")

For Each vLook In sLook

Call ProcessFolder(FSO, CStr(vLook), y)
Next vLook

End Sub

Private Function ProcessFolder(FSO As Object, FolderName As String, y)
Dim Folder As Object
Dim SubFolder As Object
Dim File As Object
Set ws = ActiveSheet
On Error Resume Next
Set Folder = FSO.getfolder(FolderName)
On Error GoTo 0
If Not Folder Is Nothing Then

For Each File In Folder.files
    If Not Left(File.Name, 1) Like "~" Then
        If File.Name Like "*." & y Then
        ws.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = File.Name
        End If
    End If
Next File

For Each SubFolder In Folder.SubFolders
    Call ProcessFolder(FSO, FolderName & SubFolder.Name & "\", y)
    Next SubFolder
End If

Set Folder = Nothing
Set SubFolder = Nothing
End Function

 

[geep1980]

ik bedenk me net dat ik vergeten ben er een hyperlink van te maken.
Vervang onderstaande code

ws.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = File.Path

door

ws.Hyperlinks.Add anchor:=Cells(Rows.Count, "A").End(xlUp).Offset(1, 0), Address:= _
        File.Path, TextToDisplay:=File.Name

Hij laat nu alleen de bestandsnaam zien maar linkt naar het bestand als je er op klikt

 

[AABE]

Bedankt.... ik zal het a.s. maandag uittesten.

 

[AABE]

Het werkt..... bedankt

 

[danvie]

ik heb geprobeerd de code in een excel te plaatsen maar krijg het niet draaiende.
Ik ben hier erg in geinteresseerd en zou dit tooltje graag aan mijn collectie toevoegen.
Zou je een werkend bestand willen posten.

Bij voorbaat dank

 

[Warme bakkertje]

In je werkblad
ALT+F11 >> Invoegen >> Module
In het rechtervenster beide code-stukjes plakken.
Sub A uitvoeren.

 

[geep1980]

Zie bijge bestand.
Ik heb hem nu zo gemaakt dat je zelf de directory op moet geven waar je in wil zoeken gevolgd door de extentie waar je op wil zoekenBekijk bijlage Zoeken_in_door__directory_naar_bestanden.xlsm