Import file names from subfolders into an access table.

[Hanss]

The following code creates a new table in access and imports the file names into the table. The problem is that it only imports the names from the last subdirectory, not from the other directories. Would appreciate any help in fixing this.

Hanss
Zurich

Command in immediate window:

? appendfilelist ("c:\test","True" )



Code:

Public Function AppendFileList(strFolder As String, IncludeSubFolders As Boolean)
On Error GoTo errHandler

Dim objFSO As FileSystemObject
Dim objFolder As Folder
Dim objFiles As File
Dim strFileNames As String
Dim strSubFolder As Folder

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolder)


'CREATE TABLE OF FILES
'---------------------

'Drop table TblFiles first
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * from TblFileList"
DoCmd.DeleteObject acTable, "TblFileList"

'Create Table TblFileList
DoCmd.RunSQL "Create Table TblFileList (Filename Text(255), Folder Text(255), [FileSize (KB)] Number);"


'To scan root files
'------------------

For Each objFiles In objFolder.Files

' SysCmd acSysCmdSetStatus, objFolder.Path

DoCmd.SetWarnings False
strCount = strCount + 1
DoCmd.RunSQL ("Insert Into TblFileList Values('" & objFiles.Name & "','" & objFolder.Path & "'," & Round(objFiles.Size / 1024, 2) & ");")
DoCmd.SetWarnings True
DoEvents
strFilesFound = strFilesFound & vbCrLf & objFiles.Name

Next


'To scan sub folders
'-------------------
If IncludeSubFolders = True Then

For Each strSubFolder In objFolder.SubFolders
Call AppendFileList(strSubFolder.Path, True)
Next

End If

errHandler:
If Err.Number > 0 Then

If MsgBox("Encountered following error. " & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf & "Do you want to exit?", vbYesNo + vbExclamation, "Error") = vbYes Then
End
Else
Resume Next
End If

End If

End Function

 

[PHV]

I'd recreate the table outside the recursive procedure ...

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Hanss]

Thank you very much for looking at this! I just tried what you suggested, but it still only takes the files out of the last subdirectory. If have the following directory tree:

c:\test\dir1\dir2\

only files from dir2 will be appended and none from the “test” and “dir1” directories.

Kind regards,
Hanss

Here is the new code that I tried:

Public Function cmdStart_Click()
'CREATE TABLE OF FILES
'---------------------

'Drop table TblFiles first
DoCmd.SetWarnings False
'DoCmd.RunSQL "Delete * from TblFileList"
'DoCmd.DeleteObject acTable, "TblFileList"

'Create Table TblFileList
DoCmd.RunSQL "Create Table TblFileList (Filename Text(255), Folder Text(255), [FileSize (KB)] Number);"

Call getfiles("c:\test”, "true")

End Function

Public Function getfiles(strFolder As String, IncludeSubFolders As Boolean)
On Error GoTo errHandler

Dim objFSO As FileSystemObject
Dim objFolder As Folder
Dim objFiles As file
Dim strFileNames As String
Dim strSubFolder As Folder

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolder)


'To scan root files
'------------------

For Each objFiles In objFolder.files

' SysCmd acSysCmdSetStatus, objFolder.Path

DoCmd.SetWarnings False
strCount = strCount + 1
DoCmd.RunSQL ("Insert Into TblFileList Values('" & objFiles.Name & "','" & objFolder.path & "'," & Round(objFiles.Size / 1024, 2) & ");")
DoCmd.SetWarnings True
DoEvents
strFilesFound = strFilesFound & vbCrLf & objFiles.Name

Next


'To scan sub folders
'-------------------
If IncludeSubFolders = True Then

For Each strSubFolder In objFolder.SubFolders
Call AppendFileList(strSubFolder.path, True)

Next

End If

errHandler:
If Err.Number > 0 Then

If MsgBox("Encountered following error. " & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf & "Do you want to exit?", vbYesNo + vbExclamation, "Error") = vbYes Then
End
Else
Resume Next
End If

End If

End Function