B
BrianPaul
Option Compare Database
Option Explicit
Public Function ListFiles(strPath As String, Optional strFileSpec As String,
Optional bIncludeSubfolders As Boolean, Optional lst As Object)
On Error GoTo Err_Handler
'Purpose: List the files in the path.
'Arguments: strPath = the path to search.
' strFileSpec = "*.*" unless you specify differently.
' bIncludeSubfolders: If True, returns results from
subdirectories of strPath as well.
' lst: if you pass in a list box, items are added to it. If
'not, files are listed to immediate window.
' The list box must have its Row Source Type property set
'to Value List.
'Method: FilDir() adds items to a collection, calling itself
'recursively for subfolders.
Dim colDirList As New Collection
Dim varItem As Variant
Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
'Add the files to a list box if one was passed in. Otherwise list to the
'Immediate Window.
If lst Is Nothing Then
For Each varItem In colDirList
Debug.Print varItem
Next
Else
If TypeOf lst Is DAO.Recordset Then
For Each varItem In colDirList
lst.AddNew
lst.Fields(0) = varItem
lst.Update
Next
ElseIf TypeOf lst Is Collection Then
For Each varItem In colDirList
lst.Add varItem
Next
ElseIf TypeOf lst Is ListBox Then
For Each varItem In colDirList
lst.AddItem varItem
Next
End If
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
End Function
Private Function FillDir(colDirList As Collection, ByVal strFolder As
String, strFileSpec As String, _
bIncludeSubfolders As Boolean)
'Build up a list of files, and then add add to this list, any additional
folders
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName),
strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function
'****************************************************
'You can then call the code like this
'****************************************************
Function testRs()
Dim strPath As String
Dim strFileSpec As String
Dim bIncludeSubfolders As Boolean
Dim d As DAO.Database
Dim c As DAO.Recordset
Dim i As Integer
'*****************SPECIFY THE PATH YOU WANT*************
strPath = "Q:\"
strFileSpec = "*.*"
bIncludeSubfolders = True
Set d = CurrentDb
' Uncomment the following line if you want to empty the target table before
'filling it again
' d.Execute "DELETE * FROM [TItem]"
Set c = d.OpenRecordset("SELECT [MP3] FROM [TMP3]", dbOpenDynaset)
'Set c = d.OpenRecordset("SELECT [MP3] FROM [TMP3Back]", dbOpenDynaset)
Call ListFiles(strPath, strFileSpec, bIncludeSubfolders, c)
c.Close
Set c = Nothing
Set d = Nothing
End Function
'****************************************************
I want to modify this:
strPath = "Q:\"
strFileSpec = "*.*"
Where right now You have to specify the Q Drive.
I would like the end user of the database select the Drive Letter and
directory of the files so It would import them in.
I have a button on the main form that deletes the table and repopulates it
based on this code:
DoCmd.Close
DBEngine(0)(0).Execute "DELETE FROM TMP3;", dbFailOnError
DBEngine(0)(0).Execute "DELETE FROM TMP3Back;", dbFailOnError
Call testRs
Call testRsBack
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "MainMenu"
DoCmd.OpenForm stDocName, , , stLinkCriteria
DoCmd.Maximize
End Sub
Private Sub Form_Load()
'Written by Helen Feddema 11-2-2000
'Last modified 11-2-2000
On Error GoTo ErrorHandler
Dim strSQL As String
'DoCmd.RunCommand acCmdSizeToFitForm
DoCmd.SetWarnings False
'Clear tables of available and selected items
strSQL = "DELETE * FROM TMP3Selected"
DoCmd.RunSQL strSQL
strSQL = "DELETE * FROM TMP3BACK"
DoCmd.RunSQL strSQL
'Fill table of available items from table of categories
strSQL = "INSERT INTO TMP3Back (MP3) " _
& "SELECT MP3 FROM TMP3;"
DoCmd.RunSQL strSQL
Me![List27].Requery
'Me![ResultMP3].Requery
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End Sub
Option Explicit
Public Function ListFiles(strPath As String, Optional strFileSpec As String,
Optional bIncludeSubfolders As Boolean, Optional lst As Object)
On Error GoTo Err_Handler
'Purpose: List the files in the path.
'Arguments: strPath = the path to search.
' strFileSpec = "*.*" unless you specify differently.
' bIncludeSubfolders: If True, returns results from
subdirectories of strPath as well.
' lst: if you pass in a list box, items are added to it. If
'not, files are listed to immediate window.
' The list box must have its Row Source Type property set
'to Value List.
'Method: FilDir() adds items to a collection, calling itself
'recursively for subfolders.
Dim colDirList As New Collection
Dim varItem As Variant
Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
'Add the files to a list box if one was passed in. Otherwise list to the
'Immediate Window.
If lst Is Nothing Then
For Each varItem In colDirList
Debug.Print varItem
Next
Else
If TypeOf lst Is DAO.Recordset Then
For Each varItem In colDirList
lst.AddNew
lst.Fields(0) = varItem
lst.Update
Next
ElseIf TypeOf lst Is Collection Then
For Each varItem In colDirList
lst.Add varItem
Next
ElseIf TypeOf lst Is ListBox Then
For Each varItem In colDirList
lst.AddItem varItem
Next
End If
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
End Function
Private Function FillDir(colDirList As Collection, ByVal strFolder As
String, strFileSpec As String, _
bIncludeSubfolders As Boolean)
'Build up a list of files, and then add add to this list, any additional
folders
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName),
strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function
'****************************************************
'You can then call the code like this
'****************************************************
Function testRs()
Dim strPath As String
Dim strFileSpec As String
Dim bIncludeSubfolders As Boolean
Dim d As DAO.Database
Dim c As DAO.Recordset
Dim i As Integer
'*****************SPECIFY THE PATH YOU WANT*************
strPath = "Q:\"
strFileSpec = "*.*"
bIncludeSubfolders = True
Set d = CurrentDb
' Uncomment the following line if you want to empty the target table before
'filling it again
' d.Execute "DELETE * FROM [TItem]"
Set c = d.OpenRecordset("SELECT [MP3] FROM [TMP3]", dbOpenDynaset)
'Set c = d.OpenRecordset("SELECT [MP3] FROM [TMP3Back]", dbOpenDynaset)
Call ListFiles(strPath, strFileSpec, bIncludeSubfolders, c)
c.Close
Set c = Nothing
Set d = Nothing
End Function
'****************************************************
I want to modify this:
strPath = "Q:\"
strFileSpec = "*.*"
Where right now You have to specify the Q Drive.
I would like the end user of the database select the Drive Letter and
directory of the files so It would import them in.
I have a button on the main form that deletes the table and repopulates it
based on this code:
DoCmd.Close
DBEngine(0)(0).Execute "DELETE FROM TMP3;", dbFailOnError
DBEngine(0)(0).Execute "DELETE FROM TMP3Back;", dbFailOnError
Call testRs
Call testRsBack
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "MainMenu"
DoCmd.OpenForm stDocName, , , stLinkCriteria
DoCmd.Maximize
End Sub
Private Sub Form_Load()
'Written by Helen Feddema 11-2-2000
'Last modified 11-2-2000
On Error GoTo ErrorHandler
Dim strSQL As String
'DoCmd.RunCommand acCmdSizeToFitForm
DoCmd.SetWarnings False
'Clear tables of available and selected items
strSQL = "DELETE * FROM TMP3Selected"
DoCmd.RunSQL strSQL
strSQL = "DELETE * FROM TMP3BACK"
DoCmd.RunSQL strSQL
'Fill table of available items from table of categories
strSQL = "INSERT INTO TMP3Back (MP3) " _
& "SELECT MP3 FROM TMP3;"
DoCmd.RunSQL strSQL
Me![List27].Requery
'Me![ResultMP3].Requery
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End Sub