Improve company productivity with a Business Account.Sign Up

x
?
Solved

Access function help with folder and file list

Posted on 2009-05-13
5
Medium Priority
?
320 Views
Last Modified: 2013-11-27
Hello EE,

From different sources I have gotten multiple ways to pull folder, subfolder, and file information using Access 2003.  The code below represents the easiest way for me to get folders, their subfolders, and file name info into an Access table.  However, it does not provide the file date or the file size.  I added the DIMs, but don't know how to pull the date and size as it is looping through.  Can you help?  The bulk of the code below is courtesy of Allen Browne.

Thanks,

LVBarnes
Sub runListFiles()
    'Usage example.
    Dim strPath As String
    Dim strFileSpec As String
    Dim booIncludeSubfolders As Boolean
    Dim gCount As Long
    Dim FileDate As String
    Dim FileSize As Long
    
            
    strPath = "C:\"
    strFileSpec = "*.*"
    booIncludeSubfolders = True
    
    ListFilesToTable strPath, strFileSpec, booIncludeSubfolders
End Sub
 
Public Function ListFilesToTable(strPath As String _
    , Optional strFileSpec As String = "*.*" _
    , Optional bIncludeSubfolders As Boolean _
    )
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.
    'Method:    FilDir() adds items to a collection, calling itself recursively for subfolders.
    
    Dim colDirList As New Collection
    Dim varitem As Variant
    Dim rst As DAO.Recordset
    Dim mStartTime As Date
    Dim mSeconds As Long
    Dim mMin As Long
    Dim mMsg As String
    Dim gCount As Long
      
      
   mStartTime = Now()
   '--------
    
    Call FillDirToTable(colDirList, strPath, strFileSpec, bIncludeSubfolders)
      
   mSeconds = DateDiff("s", mStartTime, Now())
   
   mMin = mSeconds \ 60
   If mMin > 0 Then
      mMsg = mMin & " min "
      mSeconds = mSeconds - (mMin * 60)
   Else
      mMsg = ""
   End If
   
   mMsg = mMsg & mSeconds & " seconds"
   
   MsgBox "Done adding " & Format(gCount, "#,##0") & " files from " & strPath _
      & IIf(Len(Trim(strFileSpec)) > 0, " for file specification --> " & strFileSpec, "") _
      & vbCrLf & vbCrLf & mMsg, , "Done"
  
Exit_Handler:
   SysCmd acSysCmdClearStatus
   '--------
    
    Exit Function
 
Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, , "ERROR"
    
    'remove next line after debugged -- added by Crystal
    'Stop: Resume 'added by Crystal
    
    Resume Exit_Handler
End Function
 
Private Function FillDirToTable(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
    On Error GoTo Err_Handler
    
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant
    Dim strSQL As String
    Dim gCount As Long
    Dim FileDate As String
    Dim FileSize As Long
 
    'Add the files to the folder.
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    'FileDate = HELP HERE
    Do While strTemp <> vbNullString
         gCount = gCount + 1
         SysCmd acSysCmdSetStatus, gCount
         strSQL = "INSERT INTO tblFiles " & " (FName, FPath, FDate, FSize) " & _
         " SELECT """ & strTemp & """" & ", """ & strFolder & """, """ & FileDate & """, """ & FileSize & """;"
         CurrentDb.Execute strSQL
        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 FillDirToTable(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
        Next vFolderName
    End If
 
Exit_Handler:
    
    Exit Function
 
Err_Handler:
    strSQL = "INSERT INTO tblFiles " _
    & " (FName, FPath) " _
    & " SELECT ""  ~~~ ERROR ~~~""" _
    & ", """ & strFolder & """;"
    CurrentDb.Execute strSQL
    
    Resume Exit_Handler
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

Open in new window

0
Comment
Question by:Lawrence Barnes
  • 3
  • 2
5 Comments
 
LVL 120

Expert Comment

by:Rey Obrero (Capricorn1)
ID: 24379546


 strTemp = Dir(strFolder & strFileSpec)
    'FileDate = HELP HERE

     FileDate=fileDateTime(strFolder & strFileSpec)
     
     FileSize=fileLen(strFolder & strFileSpec)
0
 
LVL 120

Expert Comment

by:Rey Obrero (Capricorn1)
ID: 24379559
oops sorry

strTemp = Dir(strFolder & strFileSpec)
    'FileDate = HELP HERE

     FileDate=fileDateTime(strFolder & strTemp)
     
     FileSize=fileLen(strFolder & strTemp)
0
 
LVL 5

Author Comment

by:Lawrence Barnes
ID: 24379830
Hi Capricorn :)

Thanks to you I am now getting a file date and a file size :)  BUT, thanks to me I'm getting the same file date/file size for every file within a directory.  Probably because it's in the wrong part of the loop.  I'll continue to hack on it.. but could you tell me where I should place the filedate/filesize code?  New code pasted below.

I could startup another question if needed.

LVBarnes
Option Compare Database
 
Option Explicit
 
Sub runListFiles()
    'Usage example.
    Dim strPath As String
    Dim strFileSpec As String
    Dim booIncludeSubfolders As Boolean
    Dim gCount As Long
    Dim FileDate As String
    Dim FileSize As Long
    
            
    strPath = "C:\"
    strFileSpec = "*.*"
    booIncludeSubfolders = True
    
    ListFilesToTable strPath, strFileSpec, booIncludeSubfolders
End Sub
 
Public Function ListFilesToTable(strPath As String _
    , Optional strFileSpec As String = "*.*" _
    , Optional bIncludeSubfolders As Boolean _
    )
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.
    'Method:    FilDir() adds items to a collection, calling itself recursively for subfolders.
    
    Dim colDirList As New Collection
    Dim varitem As Variant
    Dim rst As DAO.Recordset
    Dim mStartTime As Date
    Dim mSeconds As Long
    Dim mMin As Long
    Dim mMsg As String
    Dim gCount As Long
      
      
   mStartTime = Now()
   '--------
    
    Call FillDirToTable(colDirList, strPath, strFileSpec, bIncludeSubfolders)
      
   mSeconds = DateDiff("s", mStartTime, Now())
   
   mMin = mSeconds \ 60
   If mMin > 0 Then
      mMsg = mMin & " min "
      mSeconds = mSeconds - (mMin * 60)
   Else
      mMsg = ""
   End If
   
   mMsg = mMsg & mSeconds & " seconds"
   
   MsgBox "Done adding " & Format(gCount, "#,##0") & " files from " & strPath _
      & IIf(Len(Trim(strFileSpec)) > 0, " for file specification --> " & strFileSpec, "") _
      & vbCrLf & vbCrLf & mMsg, , "Done"
  
Exit_Handler:
   SysCmd acSysCmdClearStatus
   '--------
    
    Exit Function
 
Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, , "ERROR"
    
    'remove next line after debugged -- added by Crystal
    'Stop: Resume 'added by Crystal
    
    Resume Exit_Handler
End Function
 
Private Function FillDirToTable(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
    On Error GoTo Err_Handler
    
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant
    Dim strSQL As String
    Dim gCount As Long
    Dim FileDate As String
    Dim FileSize As Long
 
    'Add the files to the folder.
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    FileDate = FileDateTime(strFolder & strTemp)
    FileSize = FileLen(strFolder & strTemp)
    
    Do While strTemp <> vbNullString
         gCount = gCount + 1
         SysCmd acSysCmdSetStatus, gCount
         strSQL = "INSERT INTO tblFiles " & " (FName, FPath, FDate, FSize) " & _
         " SELECT """ & strTemp & """" & ", """ & strFolder & """, """ & FileDate & """, """ & FileSize & """;"
         CurrentDb.Execute strSQL
        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 FillDirToTable(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
        Next vFolderName
    End If
 
Exit_Handler:
    
    Exit Function
 
Err_Handler:
    strSQL = "INSERT INTO tblFiles " _
    & " (FName, FPath, FDate, FSize) " _
    & " SELECT ""  ~~~ ERROR ~~~""" _
    & ", """ & strFolder & """, """ & FileDate & """, """ & FileSize & """;"
    CurrentDb.Execute strSQL
    
    Resume Exit_Handler
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

Open in new window

0
 
LVL 120

Accepted Solution

by:
Rey Obrero (Capricorn1) earned 2000 total points
ID: 24379847


place it inside the loop


   
    Do While strTemp <> vbNullString

         FileDate = FileDateTime(strFolder & strTemp)
          FileSize = FileLen(strFolder & strTemp)
0
 
LVL 5

Author Closing Comment

by:Lawrence Barnes
ID: 31581209
Thank you again Capricorn :)
0

Featured Post

Get 10% Off Your First Squarespace Website

Ready to showcase your work, publish content or promote your business online? With Squarespace’s award-winning templates and 24/7 customer service, getting started is simple. Head to Squarespace.com and use offer code ‘EXPERTS’ to get 10% off your first purchase.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

We live in a world of interfaces like the one in the title picture. VBA also allows to use interfaces which offers a lot of possibilities. This article describes how to use interfaces in VBA and how to work around their bugs.
Beware when using the ListIndex and the Column() properties of a listbox in Access 2007.  A bug has been identified in the Access 2007 listbox code which can cause the .ListIndex property to return a -1, and the .Columns(#) property to return a NULL…
Visualize your data even better in Access queries. Given a date and a value, this lesson shows how to compare that value with the previous value, calculate the difference, and display a circle if the value is the same, an up triangle if it increased…
Have you created a query with information for a calendar? ... and then, abra-cadabra, the calendar is done?! I am going to show you how to make that happen. Visualize your data!  ... really see it To use the code to create a calendar from a q…

606 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question