Can the below code be modified for select. Drive Letter, Dir.



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
If TypeOf lst Is DAO.Recordset Then
For Each varItem In colDirList
lst.Fields(0) = varItem
ElseIf TypeOf lst Is Collection Then
For Each varItem In colDirList
lst.Add varItem
ElseIf TypeOf lst Is ListBox Then
For Each varItem In colDirList
lst.AddItem varItem
End If
End If

Exit Function

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
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

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
'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
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)

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:


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


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
DoCmd.RunSQL strSQL
'Fill table of available items from table of categories
strSQL = "INSERT INTO TMP3Back (MP3) " _
DoCmd.RunSQL strSQL

Exit Sub

MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit

End Sub

Piet Linden

Open the OpenSaveFile dialog to a specific location...

Here's what Terry Kreft says in his article, "API: BrowseFolder
Dialog", here:

Stephen Lebans has added functionality to open the browse folder at a
specific place.

so toss the code you got from Helen Feddema... use Stephen's instead.
All of his code is obscenely well documented. You can even download a
working example to modify. Maybe import his stuff into your database,
modify and get it working, then put in your real form...

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question