Hi,
I have code that will return all the file names of a specified type from a
directory that you select. I created two modules to handle this:
AllDocsInFolderTree and DirectoryListArray (almost all of the code, though,
comes from the MVPs site).
In the module AllDocsInFolderTree, I have the following code (the first
routine calls other functions which call other functions). In "Public
Function fGetFolder(sFolderName As String)", make sure that you specify what
file extension you want to look for.
Good luck.
Option Explicit
Sub GetAllDocsFromFolderTree()
With Dialogs(wdDialogCopyFile)
If .Display <> 0 Then
fGetFolder sFolderName:=Replace(.directory, Chr(34), "")
Else
MsgBox "Dialog cancelled"
End If
End With
End Sub
Public Function fGetFolder(sFolderName As String)
Dim FoldersArray As Variant
Dim aFileNames As Variant
Dim lCounter As Long
Dim oDoc As Document
Dim i As Integer
Debug.Print sFolderName
'Read all subfolders of the specified folder into an array
'by calling the funcGetSubfolders function
FoldersArray = funcGetSubfolders(sFolderName)
'Put the results (the array values) into a new document
Set oDoc = Documents.Add
For i = LBound(FoldersArray) To UBound(FoldersArray)
aFileNames = DirectoryListArray.fDirectoryListArray _
(sPath:=CStr(FoldersArray(i)), _
sExtension:=".doc")
If UBound(aFileNames) > 0 Then
For lCounter = LBound(aFileNames) To UBound(aFileNames)
oDoc.Range.InsertAfter text:=FoldersArray(i) &
aFileNames(lCounter) & vbCrLf
Next lCounter
End If
Next i
ActiveDocument.Saved = True
End Function
Public Function funcGetSubfolders(ByVal FolderToRead As String) As Variant
'This function uses a string as a parameter and not an array.
'It translates this string to an array and then starts the main function,
'funcGetAllSubfolders'
Dim AllSubFolders(0) As Variant
On Error Resume Next
System.Cursor = wdCursorWait
'Add a backslash to the end of the path, if not there already
If (Right$(FolderToRead, 1) <> "\") Then
FolderToRead = FolderToRead & "\"
End If
'Set the path as the first entry in the array and pas the array to the main
function
AllSubFolders(0) = FolderToRead
funcGetSubfolders = funcGetAllSubfolders(AllSubFolders)
System.Cursor = wdCursorNormal
StatusBar = ""
On Error GoTo 0
End Function
Private Function funcGetAllSubfolders(ByVal AllSubFoldersArray As Variant)
As Variant
'This is a recursive function, that is, it keeps calling itself -
'which makes it a nightmare to step through!
Dim Counter As Integer
'The following string will contain the path of the folder which is currently
being looked in
Dim CurFolderName As String
'The following string will contain the current value returned by Dir$().
Dim SubFolderName As String
'The following array will contain of the subfolders (if any) of
'CurFolderName'
Dim SubFolderList() As String
On Error Resume Next
'Get the last value we put into the AllSubFoldersArray Array variant,
'and convert it to a string so that we can assign it to the string
'variable CurFolderName
CurFolderName = CStr(AllSubFoldersArray(UBound(AllSubFoldersArray)))
'Read all subfolders of 'CurFolderName' and add them to 'SubFolderList'.
ReDim SubFolderList(0)
SubFolderName = Dir$(CurFolderName, vbDirectory)
Do While Len(SubFolderName) <> 0
'Ignore the current directory and the encompassing directory.
If SubFolderName <> "." And SubFolderName <> ".." Then
'Unfortunately, calling Dir with the vbDirectory attribute
'does not continually return subdirectories (only the first time);
'so you have to use the GetAttr function (which is covered in Help)
'to test, each time, that this is a folder and not a file
If (GetAttr(CurFolderName & SubFolderName) _
And vbDirectory) = vbDirectory Then
'Up the array size by one
ReDim Preserve SubFolderList(UBound(SubFolderList) + 1)
'Add the new folder to the array
SubFolderList(UBound(SubFolderList)) = SubFolderName
StatusBar = "Reading Subfolders... (" _
& CurFolderName & ": -> " & SubFolderName & ")"
End If
End If
'Get the next directory
SubFolderName = Dir$()
Loop
'Sort the list with the subfolders.
If UBound(SubFolderList) > 0 Then
WordBasic.SortArray SubFolderList()
End If
'Now get all the subfolders of the current folder, then all the subfolders
'of each of those subfolders, and so on, up the directory tree,
'until there are no more subfolders. By recursively
'(repeatedly applying the procedure to successive results)
'calling the current function.
'If the current folder contains no subfolders, the following For .. Next
loop gets skipped
For Counter = 1 To UBound(SubFolderList)
'Up the size of the AllSubFoldersArray array by one
ReDim Preserve AllSubFoldersArray(UBound(AllSubFoldersArray) + 1)
'Set the next item in the AllSubFoldersArray to be
'the next subfolder of the current folder
AllSubFoldersArray(UBound(AllSubFoldersArray)) = _
CurFolderName & SubFolderList(Counter) & "\"
'Now run the this function recursively on that subfolder,
'to get its subfolders, if it has any
AllSubFoldersArray = funcGetAllSubfolders(AllSubFoldersArray)
Next Counter
'Set the complete directory structure as the function's return value.
funcGetAllSubfolders = AllSubFoldersArray
On Error GoTo 0
End Function
IN the DirectoryListArry module, I have the following code
Option Explicit
Public Function fDirectoryListArray( _
sPath As String, _
sExtension As String) As Variant
Dim MyFile As String
Dim Counter As Long
'Create a dynamic array variable, and then declare its initial size
Dim DirectoryListArray() As String
ReDim DirectoryListArray(1000)
Counter = 0
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$(sPath & "*" & sExtension)
Debug.Print sPath & "*" & sExtension
Do While MyFile <> ""
DirectoryListArray(Counter) = MyFile
MyFile = Dir$
Counter = Counter + 1
Loop
'Reset the size of the array without losing its values by using Redim
Preserve
If Counter <> 0 Then
ReDim Preserve DirectoryListArray(Counter - 1)
Else
ReDim Preserve DirectoryListArray(0)
End If
fDirectoryListArray = DirectoryListArray
End Function
Public Sub UseDirectoryListArray()
Dim aDir As Variant
Dim iCount As Integer
Dim oDoc As Document
Set oDoc = Documents.Add
aDir = fDirectoryListArray(sPath:="C:\Documents and Settings\DLett\My
Documents\", sExtension:=".doc")
For iCount = 0 To UBound(aDir)
oDoc.Range.InsertAfter aDir(iCount) & vbCrLf
Next iCount
End Sub
HTH,
Dave
