Hallo T,
sorry, hab dich ein bißchen vergessen.
Der nachfolgende Code ist noch nicht dein Lösungscode, aber ghet in die Richtung.
Nimm ein neues leeres Dokument.
Alt+F11, Einfügen—Modul, Code reinkopieren.
In der Codezeile
For Each Datei In GetFiles(„C:\test“, True, „*.doc“)
änderts du C:\test ab auf den Oberordner/Pfad der bei dir gilt.
Das True danach gibt an daß auch Unterordner durchsucht werden, wenn du das nicht willst mache aus dem True ein False.
Mit Extras—Verweise kannst du den im Code erwähnten Verweis setzen.
Beende dann den Editor. In Word dann Alt+F8 und lasse das Makro Dateilisten ausführen.
Jetzt müßte im aktuellen Dokument eine Auflistung aller .docs kommen. Klappts?
Gruß
Reinhard
Option Explicit
' Achtung!
' --\> Microsoft Scripting Runtime - Verweis notwendig!
Sub Dateilisten()
Dim Datei As File, Zei As Long
Application.ScreenUpdating = False
For Each Datei In GetFiles("C:\test", True, "\*.doc")
Selection.TypeText Text:=Datei.Path
Selection.TypeParagraph
Next
Application.ScreenUpdating = True
End Sub
'
Public Function GetFiles(FolderPath As String, scanSubDirectorys As Boolean, Optional \_
SearchPattern As String, Optional SortBy As String) As Collection
' Die MSR - Objekte
Dim objFs As New FileSystemObject
Dim objRootFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
' Zwischenspeicher für den Rückgabewert der Funktion
Dim HColl As New Collection
Set HColl = Nothing
' Wenn kein Suchmuster angegeben alle Dateien zurückliefern
If SearchPattern = "" Then SearchPattern = "\*"
' Das Ordner-Objekt für den angegebenen Pfad laden
On Error GoTo err01
Set objRootFolder = objFs.GetFolder(FolderPath)
err01:
If Err.Number 0 Then
Set GetFiles = HColl
Exit Function
End If
' Alle Dateien in diesem Ordner durchlaufen
For Each objFile In objRootFolder.Files
' Wenn das Suchmuster übereinstimmt Datei der Collection hinzufügen
If objFile.Name Like SearchPattern Then
HColl.Add objFile
End If
Next
' Wenn angegeben, die Unterordner des Startpfades durchlaufen
If scanSubDirectorys Then
For Each objSubFolder In objRootFolder.SubFolders
' Alle per Rekursion zurückgelieferten Dateien der Hilfscollection hinzufügen
For Each objFile In GetFiles(objSubFolder.Path, scanSubDirectorys, SearchPattern)
HColl.Add objFile
Next
Next
End If
' Wenn angegeben, die Hilfs-Collection sortieren
If SortBy "" Then
Set HColl = SortItemCollection(HColl, SortBy)
End If
' Rückgabewert
Set GetFiles = HColl
End Function
'
Public Function SortItemCollection(col As Collection, strPropertyName) As Collection
Dim colNew As Collection
Dim objCurrent As Object
Dim objCompare As Object
Dim lngCompareIndex As Long
Dim variantCurrent As Variant
Dim variantCompare As Variant
Dim blnGreaterValueFound As Boolean
'make a copy of the collection, ripping through it one item
'at a time, adding to new collection in right order...
Set colNew = New Collection
For Each objCurrent In col
'get value of current item...
variantCurrent = CallByName(objCurrent, strPropertyName, VbGet)
'setup for compare loop
blnGreaterValueFound = False
lngCompareIndex = 0
For Each objCompare In colNew
lngCompareIndex = lngCompareIndex + 1
variantCompare = CallByName(objCompare, strPropertyName, VbGet)
'die Vergleichstypen auf Variant geändert, somit können beliebige Datentypen \_
miteinander verglichen werden
If variantCurrent