title: VBA output previous folder name in field
body: <p>I'm having trouble with figuring out how to get the name of a folder to output to a separate field in MS Access. So far I've managed to use this Allen Browne script and tweaked it to output the file name and the path as one field.</p>
  
  <p>All of the files in this search are contained within sub folders, and it is important to output the last sub folder name in a separate field for my purposes. Something like this:
  <img src="https://i.stack.imgur.com/BWN47.png" alt="ExampleTable"></p>
  
  <p>Here's the code:</p>
  
  <pre><code>Option Compare Database
  Option Explicit
  
  'list files to tables
  'http://allenbrowne.com/ser-59alt.html
  
  Dim gCount As Long ' added by Crystal
  
  Sub runListFiles()
      'Usage example.
      Dim strPath As String _
      , strFileSpec As String _
      , booIncludeSubfolders As Boolean
  
      strPath = "H:\Pictures\2019"
      strFileSpec = "*.*"
      booIncludeSubfolders = True
  
      ListFilesToTable strPath, strFileSpec, booIncludeSubfolders
  End Sub
  
  '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 &gt; 0 Then
        mMsg = mMin &amp; " min "
        mSeconds = mSeconds - (mMin * 60)
     Else
        mMsg = ""
     End If
  
     mMsg = mMsg &amp; mSeconds &amp; " seconds"
  
     MsgBox "Done adding " &amp; Format(gCount, "#,##0") &amp; " files from " &amp; strPath _
        &amp; IIf(Len(Trim(strFileSpec)) &gt; 0, " for file specification --&gt; " &amp; strFileSpec, "") _
        &amp; vbCrLf &amp; vbCrLf &amp; mMsg, , "Done"
  
  Exit_Handler:
     SysCmd acSysCmdClearStatus
     '--------
  
      Exit Function
  
  Err_Handler:
      MsgBox "Error " &amp; Err.Number &amp; ": " &amp; Err.Description, , "ERROR"
  
      'remove next line after debugged -- 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 &amp; strFileSpec)
      Do While strTemp &lt;&gt; vbNullString
           gCount = gCount + 1
           SysCmd acSysCmdSetStatus, gCount
           strSQL = "INSERT INTO Files " _
            &amp; " (FPath) " _
            &amp; " SELECT """ &amp; strFolder &amp; """" _
            &amp; "&amp; """ &amp; strTemp &amp; """;"
           CurrentDb.Execute strSQL
          colDirList.Add strFolder &amp; strTemp
          strTemp = Dir
      Loop
  
      If bIncludeSubfolders Then
          'Build collection of additional subfolders.
          strTemp = Dir(strFolder, vbDirectory)
          Do While strTemp &lt;&gt; vbNullString
              If (strTemp &lt;&gt; ".") And (strTemp &lt;&gt; "..") Then
                  If (GetAttr(strFolder &amp; strTemp) And vbDirectory) &lt;&gt; 0&amp; 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 &amp; TrailingSlash(vFolderName), strFileSpec, True)
          Next vFolderName
      End If
  
  Exit_Handler:
  
      Exit Function
  
  Err_Handler:
      strSQL = "INSERT INTO Files " _
      &amp; " (FPath) " _
      &amp; " SELECT ""  ~~~ ERROR ~~~""" _
      &amp; ", """ &amp; strFolder &amp; """;"
      CurrentDb.Execute strSQL
  
      Resume Exit_Handler
  End Function
  
  Public Function TrailingSlash(varIn As Variant) As String
      If Len(varIn) &gt; 0&amp; Then
          If Right(varIn, 1&amp;) = "\" Then
              TrailingSlash = varIn
          Else
              TrailingSlash = varIn &amp; "\"
          End If
      End If
  End Function
  </code></pre>