Office: Unterverzeichnis auslesen

Hallo zusammen,
mal wieder steh ich auf dem Schlauch *stupid und würde mich freuen, wenn mir jemand helfen könnte.*sos

Ich lese mit dem folgende Script ein Verzeichnis aus. jede gefundene Datei erzeugt eine Excelzeile.
Soweit Sogut
Frage : Wie bekomme ich es hin, dass mir auch die Unterverzeichnisse mit ausgelesen werden ??

Könnt ihr mir helfen ??

HTML:

Sub Dateien_ermitteln()
Dim i As Long, intPos As Integer
Dim Dateidatum As Date
Dim KW As Integer
'------------------------------
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("scripting.filesystemobject")
Dim DatNam
Dim BB
'------------------------------
'KW = Range("AA1")
strsuchpfad = VerzeichnisErmitteln(s)
If strsuchpfad = False Then Exit Sub
If strsuchpfad = 0 Then Exit Sub
'-------------
DatNam = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_*.xls")
Set objFSO = CreateObject("scripting.filesystemobject")
For Each objFile In objFSO.getfolder(strsuchpfad).Files
If objFile.Name Like DatNam Then
Cells(65000, 1).End(xlUp).Offset(1, 0).Select
ActiveCell.Offset(0, 0) = strsuchpfad
ActiveCell.Offset(0, 1) = objFile.Name
ActiveCell.Offset(0, 2) = objFile.path 'strsuchpfad & "\" & objFile.Name
ActiveCell.Offset(0, 3) = objFile.datecreated
End If
Next
Set objFSO = Nothing
'------------------------------------------------


End Sub

Hatte mal was ähnlichen mit FileSearch, ABER der geht unter 2007 nicht mehr

Wäre toll wenn jemand ne idee hätte und mir helfen kann

Gruß
DeBabba

:)

 

Hallo DeBabba,

mit dem FileSystemObject benötigt man dazu eine Prozedur, die sich für jedes Unterverzeichnis rekursiv selbst aufruft. Ungetestet:

Code:

 

Hallo DeBabba,

probiers mal so.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub DateienErmitteln()
Dim objFiles() As Object, lngRet As Long, lngIndex As Long, lngRow As Long
Dim strPath As String, strFile As String

strPath = fncBrowseForFolder

If strPath <> "" Then
strFile = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_*.xls")
If strFile <> "" Then
lngRet = FileSearchINFO(objFiles, strPath, strFile, True)
If lngRet > 0 Then
lngRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
For lngIndex = 0 To lngRet - 1
Cells(lngRow + lngIndex, 1) = strPath
Cells(lngRow + lngIndex, 2) = objFiles(lngIndex).Name
Cells(lngRow + lngIndex, 3) = objFiles(lngIndex).ParentFolder.Path
Cells(lngRow + lngIndex, 4) = objFiles(lngIndex).DateCreated
Next
End If
End If
End If
End Sub

Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long

'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)


Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant

Set fobjFSO = CreateObject("Scripting.FileSystemObject")

Set ffsoFolder = fobjFSO.GetFolder(InitialPath)

On Error GoTo ErrExit

If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
Redim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next

If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If

If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function

Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object

Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)

If objFlder Is Nothing Then GoTo ErrExit

Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path

ErrExit:

Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function


Gruß Sepp

 

Hallo Ingolf,
Hallo Sepp

Vielen Dank
Ihr seit einfach die Besten. *knuddel *knuddel

Werde das mal einbauen und testen

ABER

Ich weiß jetzt schon, dass das funzt

*10points *10points *10points *happy

Nochmals Danke

Gruß
DeBabba Klaus