none
Add File Dates to VBA RRS feed

  • Question

  • Good morning,

    I'm utilizing Access 2010 on a W7 PC. The VBA below (which I found on the internet) obtains file names and file paths for the specified directory and inserts then into a table named "Files". I added two more fields to this table. Field "DateCreated" for the file date created and "DateModified" for the file date modified. Could someone show me how to include these two new fields in my VBA?

    Thank you for your help.

    Kevin

    Option Compare Database
    Option Explicit
    
    'list files to tables
    'http://allenbrowne.com/ser-59alt.html
    
    Dim gCount As Long ' added by Crystal
    
    Public Function runListFiles()
        'Usage example.
        Dim strPath As String _
        , strFileSpec As String _
        , booIncludeSubfolders As Boolean
        
        'Specify directory path
        strPath = "S:\FILE_PATH_NAME\"
    
        'Specify file extension
        strFileSpec = "*.*"
        booIncludeSubfolders = True
        
        ListFilesToTable strPath, strFileSpec, booIncludeSubfolders
    End Function
    
    'crystal modified parameter specification for strFileSpec by adding default value
    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 _
          , mSeconds As Long _
          , mMin As Long _
          , mMsg As String
          
       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"
    
       MsgBox "Import Complete", vbOKOnly, "Complete"
      
    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
    
        'Add the files to the folder.
        strFolder = TrailingSlash(strFolder)
        strTemp = Dir(strFolder & strFileSpec)
        Do While strTemp <> vbNullString
             gCount = gCount + 1
             SysCmd acSysCmdSetStatus, gCount
             strSQL = "INSERT INTO Files " _
              & " (FName, FPath) " _
              & " SELECT """ & strTemp & """" _
              & ", """ & strFolder & """;"
             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 Files " _
        & " (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

    Thursday, August 2, 2018 1:21 PM

Answers

  • 1) Add the following declarations at the top of the module, below Dim gCount as Long

    Dim fso As Object
    Dim fil As Object

    2) Add the following line to the code of runListFiles, above the line ListFilesToTable strPath strFileSpec, booIncludeSubfolders:

        Set fso = CreateObject("Scripting.FileSystemObject")

    3) In the code of ListFilesToTable, change

             strSQL = "INSERT INTO Files " _
             
    & " (FName, FPath) " _
             
    & " SELECT """ & strTemp & """" _
             
    & ", """ & strFolder & """;"

    to

             Set fil = fso.GetFile(strFolder & strTemp)
             strSQL = "INSERT INTO Files " _
              & " (FName, FPath, DateCreated, DateModified) " _
              & " SELECT """ & strTemp & """" _
              & ", """ & strFolder & """, #" _
              & Format(fil.DateCreated, "mm/dd/yyyy hh:nn:ss AM/PM") & "#, #" _
              & Format(fil.DateLastModified, "mm/dd/yyyy hh:nn:ss AM/PM") & "#"


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by KevinATF Thursday, August 2, 2018 2:48 PM
    Thursday, August 2, 2018 2:33 PM

All replies

  • 1) Add the following declarations at the top of the module, below Dim gCount as Long

    Dim fso As Object
    Dim fil As Object

    2) Add the following line to the code of runListFiles, above the line ListFilesToTable strPath strFileSpec, booIncludeSubfolders:

        Set fso = CreateObject("Scripting.FileSystemObject")

    3) In the code of ListFilesToTable, change

             strSQL = "INSERT INTO Files " _
             
    & " (FName, FPath) " _
             
    & " SELECT """ & strTemp & """" _
             
    & ", """ & strFolder & """;"

    to

             Set fil = fso.GetFile(strFolder & strTemp)
             strSQL = "INSERT INTO Files " _
              & " (FName, FPath, DateCreated, DateModified) " _
              & " SELECT """ & strTemp & """" _
              & ", """ & strFolder & """, #" _
              & Format(fil.DateCreated, "mm/dd/yyyy hh:nn:ss AM/PM") & "#, #" _
              & Format(fil.DateLastModified, "mm/dd/yyyy hh:nn:ss AM/PM") & "#"


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by KevinATF Thursday, August 2, 2018 2:48 PM
    Thursday, August 2, 2018 2:33 PM
  • Hans, that worked perfectly! Thank you. I'm uploading the finished code.

    Option Compare Database
    Option Explicit
    
    'list files to tables
    'http://allenbrowne.com/ser-59alt.html
    
    Dim gCount As Long ' added by Crystal
    Dim fso As Object
    Dim fil As Object
    
    Public Function runListFiles()
        'Usage example.
        Dim strPath As String _
        , strFileSpec As String _
        , booIncludeSubfolders As Boolean
        
        'Specify directory path
        strPath = "S:\FILE_PATH\"
    
        'Specify file extension
        strFileSpec = "*.*"
        booIncludeSubfolders = True
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        ListFilesToTable strPath, strFileSpec, booIncludeSubfolders
    End Function
    
    'crystal modified parameter specification for strFileSpec by adding default value
    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 _
          , mSeconds As Long _
          , mMin As Long _
          , mMsg As String
          
       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"
    
       MsgBox "Import Complete", vbOKOnly, "Complete"
      
    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
    
        'Add the files to the folder.
        strFolder = TrailingSlash(strFolder)
        strTemp = Dir(strFolder & strFileSpec)
        Do While strTemp <> vbNullString
             gCount = gCount + 1
             SysCmd acSysCmdSetStatus, gCount
             Set fil = fso.GetFile(strFolder & strTemp)
             strSQL = "INSERT INTO Files " _
              & " (FName, FPath, DateCreated, DateModified) " _
              & " SELECT """ & strTemp & """" _
              & ", """ & strFolder & """, #" _
              & Format(fil.DateCreated, "mm/dd/yyyy hh:nn:ss AM/PM") & "#, #" _
              & Format(fil.DateLastModified, "mm/dd/yyyy hh:nn:ss AM/PM") & "#"
             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 Files " _
        & " (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
    

    Thursday, August 2, 2018 2:50 PM