Files and Folders!

So "Application.FileSearch" is under Excel 2007 not available the following is a possibility to listed files and folders. The codes differ only in the selection of the folder and whether an hyperlink is set or not. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged in "Module1"


Option Explicit
Private strList() As String
Private lngCount As Long
Public Sub Test()
lngCount = 0
SearchFiles "C:\Temp", "*.*" 'adapt
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
.Cells.Clear
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strList)
End With
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Redim Preserve strList(lngCount)
strList(lngCount) = objFile.Name
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub

'The following code belonged in "Module2"

Option Explicit
Private strList() As String
Private strDir() As String
Private lngCount As Long
Public Sub Test_1()
lngCount = 0
SearchFiles "C:\Temp", "*.*" 'adapt
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
.Cells.Clear
.Range(.Cells(1, 2), Cells(lngCount, 2)) = _
WorksheetFunction.Transpose(strList)
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strDir)
.Columns("A:B").AutoFit
End With
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Redim Preserve strList(lngCount)
Redim Preserve strDir(lngCount)
strList(lngCount) = objFile.Name
strDir(lngCount) = strFolder & "\"
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub

'The following code belonged in "Module3"

Option Explicit
Private strList() As String
Private strDir() As String
Private lngCount As Long
Public Sub Test_2()
Dim strTMP As String
lngCount = 0
strTMP = GetFolder()
If strTMP = "" Or Left(strTMP, 1) = ":" Then Exit Sub
SearchFiles strTMP, "*.*" 'adapt
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
.Cells.Clear
.Range(.Cells(1, 2), Cells(lngCount, 2)) = _
WorksheetFunction.Transpose(strList)
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strDir)
.Columns("A:B").AutoFit
End With
End Sub
Private Function GetFolder() As String
Dim varFolder As Variant
Dim objShell As Object
Dim strPath As String
Set objShell = CreateObject("Shell.Application")
Set varFolder = objShell.BrowseForFolder(0, "Folder", &H10, 17)
If varFolder Is Nothing Then
Set varFolder = Nothing
Set objShell = Nothing
Exit Function
End If
GetFolder = varFolder.Self.Path
Set varFolder = Nothing
Set objShell = Nothing
End Function
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Redim Preserve strList(lngCount)
Redim Preserve strDir(lngCount)
strList(lngCount) = objFile.Name
strDir(lngCount) = strFolder & "\"
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub

'The following code belonged in "Module4"

Option Explicit
Private strList() As String
Private strDir() As String
Private lngCount As Long
Public Sub Test_3()
Dim strTMP As String
lngCount = 0
strTMP = GetFolder()
If strTMP = "" Or Left(strTMP, 1) = ":" Then Exit Sub
SearchFiles strTMP, "*.*" 'adapt
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
.Cells.Clear
.Range(.Cells(1, 2), Cells(lngCount, 2)) = _
WorksheetFunction.Transpose(strList)
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strDir)
.Columns("A:B").AutoFit
End With
Call Make_Link
End Sub
Private Function GetFolder() As String
Dim varFolder As Variant
Dim objShell As Object
Dim strPath As String
Set objShell = CreateObject("Shell.Application")
Set varFolder = objShell.BrowseForFolder(0, "Folder", &H10, 17)
If varFolder Is Nothing Then
Set varFolder = Nothing
Set objShell = Nothing
Exit Function
End If
GetFolder = varFolder.Self.Path
Set varFolder = Nothing
Set objShell = Nothing
End Function
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Redim Preserve strList(lngCount)
Redim Preserve strDir(lngCount)
strList(lngCount) = objFile.Name
strDir(lngCount) = strFolder & "\"
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub
Public Sub Make_Link()
Dim lngRow As Long
With ThisWorkbook.Worksheets(1)
lngRow = .Range("B" & .Rows.Count).End(xlUp).Row
For lngRow = 1 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 2), _
Address:=.Cells(lngRow, 1) & .Cells(lngRow, 2)
Next lngRow
End With
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...