File Names from a directory to text file or table

[boardgamer]

How do I get a list of filenames in a given directory to an text file or spreadsheet (Excel) or Table (Access)

 

[PHV]

Have a look at the Dir() function.

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[N1GHTEYES]

I use a routine I call DrawTree. It gets the user to browse to a folder and select whether to include subfolders or not.

Then it draws the selected folder contents (and subfolders if required) starting at the selected cell.

Copy the following code into a standard code module.

Option Private Module
Option Explicit

Private Type BrowseInfo
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Private Const MAX_PATH = 260

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
        Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
        Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
        ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Public Function BrowseFolder(Optional msg As Variant) As String
'**********************************************************************
'  1. FUNCTIONAL DESCRIPTION of BrowseFolder
'
'       This function is derived from one found on the internet.
'       It uses API functions to call a folder browse dialog to the user,
'       and return the folder selected. The return value is "" if the user selected
'       cancel.  The optional msg is presented to the user as the message in the browse box.
'       If no msg is supplied, he gets "Please select a Folder".
'
'       Note that the significant difference between this function and the inbuilt
'       Excel Application functions GetOpenFilename and GetSaveAsFilename, is that
'       this function returns a FOLDER, whereas those expect the user to select a FILE.
'
'  2. REFERENCES - None
'
'  3. INPUTS
'
'     Optional msg - Variant - message to be displayed to the user.
'
'  4. RETURN VALUE
'     String - the folder the user selected.
'
'  5. EXTERNAL EFFECTS - None
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  Dim bi As BrowseInfo
  Dim pidl As Long
  Dim Path As String
  Dim pos As Integer

  BrowseFolder = ""
 
' pointer to root folder (0 for desktop)
bi.pidlRoot = 0
' message
Dim dlgmsg As String
If IsMissing(msg) Then
  dlgmsg = "Please select a Folder"
Else
  If VarType(msg) <> vbString Then
      dlgmsg = "Please select a Folder"
  Else
      dlgmsg = msg
  End If
End If
bi.lpszTitle = dlgmsg

' browsing type (&H1 for folders)
bi.ulFlags = &H1
' show the dialog
pidl = SHBrowseForFolder(bi)
Path = Space$(MAX_PATH)

If SHGetPathFromIDList(ByVal pidl, ByVal Path) Then
  pos = InStr(Path, Chr$(0))
  BrowseFolder = left(Path, pos - 1)
End If

If (Right$(BrowseFolder, 1) <> "\" And BrowseFolder <> "") Then
  BrowseFolder = BrowseFolder & "\"
End If

Call CoTaskMemFree(pidl)

End Function

Public Sub DrawBough(sht As Worksheet, start_r As Long, start_c As Long, startfold As String, Indent As Boolean, DoSubs As Boolean)
'**********************************************************************
'  1. FUNCTIONAL DESCRIPTION of DrawBough
'
'     This sub draws a directory tree structure onto the active sheet, starting at
'     row start_R and columns Start_C on worksheet sht.
'     It draws the structure starting at startfold.
'     It is recursive, and will draw sub-folders if DoSubs is true.
'     If Indent is true, it will indent each sub-folder by one column wrt its parent.
'     (currently this happens regardless of the value of Indent)
'
'  2. REFERENCES - None
'
'  3. INPUTS - None
'
'  4. OUTPUTS - None
'
'  5. EXTERNAL EFFECTS
'     Draws a directory structure on the specified sheet, overwriting anything already there.
'
'**********************************************************************
'sht.Cells(start_r, start_c) = startfold
Dim colfolds As Collection
Dim colfiles As Collection
Dim thisitem As String
On Error Resume Next

'get the list of files and folders
thisitem = Dir(startfold, 31)
Set colfiles = New Collection
Set colfolds = New Collection

'this bit creates collections of the files and folders in this folder
While Err.Number = 0
    If thisitem <> "." And thisitem <> ".." And thisitem <> "" Then
        If (GetAttr(startfold & thisitem) And vbDirectory) Then
            colfolds.Add thisitem
        Else
            colfiles.Add thisitem
        End If
    End If
    thisitem = Dir()
Wend
Err.Clear

'draw the files in this folder
Dim f As Variant
Dim r As Long, c As Long
r = start_r
c = start_c
If Indent Then c = c + 1 'remove this line if not Indent to respond to the Indent logic
With sht
    For Each f In colfiles
        r = r + 1
        .Cells(r, c) = startfold & f
    Next f
End With
start_r = r

'draw the folders
If colfolds.count > 0 Then
    With sht
        'here is where to insert the DoSubs logic
        If DoSubs Then
            For Each f In colfolds
                DrawBough sht, start_r, c, startfold & f & "\", Indent, DoSubs
            Next f
        End If
    End With
End If
End Sub

Copy the following procedure into another module (without Option Private being set)

Public Sub AL_DrawTree()
'**********************************************************************
'  1. FUNCTIONAL DESCRIPTION of AL_DrawTree
'
'     This macro draws a directory tree structure onto the active sheet, starting at
'     the active cell.  It draws the structure starting at the folder selected by the user.
'
'  2. REFERENCES - None
'
'  3. INPUTS - None
'
'  4. OUTPUTS - None
'
'  5. EXTERNAL EFFECTS
'     Draws a directory structure on the active sheet, overwriting anything already there.
'
'**********************************************************************
'Decs
Dim sht As Worksheet
Dim r As Long, c As Long
Dim start_r As Long, start_c As Long
Dim initR As Long, initC As Long

Dim newline As String

'Note where starting
Set sht = ActiveSheet
start_r = ActiveCell.row
start_c = ActiveCell.Column
initR = start_r
initC = start_c + c

'Show a message warning the user of what will happen
Dim reply As Integer
Dim msg As String
newline = Chr(13)
msg = "This will draw a directory structure starting at the current cell: " _
    & newline & "(row" _
    & Str(start_r) _
    & ", column" _
    & Str(start_c) _
    & ", on sheet " & ActiveSheet.Name & ")" _
    & newline & "Do you want to continue?"
reply = MsgBox(msg, vbOKCancel, "Warning")
If reply = vbCancel Then Exit Sub

'get user start folder
Dim startfold As String
startfold = BrowseFolder("Select the folder from which you want the tree to be drawn.")

If startfold <> "" Then
    'User wants to continue so do so
    Dim CurrentRow As Long, CurrentCol As Long
    Dim MyRow As Long, MyCol As Long
    Dim Indent As Boolean, DoSubs As Boolean
    
    reply = MsgBox("Include Sub-Folders?", vbYesNo)
    DoSubs = (reply = vbYes)
    
    'display a "wait" message
    ActiveSheet.Cells(initR, initC + 1) = "Drawing the tree.  Please wait.  This message will disappear when the tree is complete."
    ActiveSheet.Cells(initR, initC + 1).Font.Color = RGB(255, 0, 0)
    
    'now do the actual drawing recursively
    Indent = False
    DrawBough sht, start_r, start_c, startfold, Indent, DoSubs
    
    'clear the wait message, indictaing the job is complete
    ActiveSheet.Cells(initR, initC + 1) = ""
End If
End Sub

Call the AL_DrawTree macro from the macro list (or put it onto a toolbar button).

Actually, I use a slightly different set up to my modules in the addin from which these procedures come, but it should all work if you follow the above instructions. It should certainly get you fairly close.


Tony

 

[N1GHTEYES]

For some time, I've been meaning to tidy up the Drawtree code and associated subs. You've prompted me into doing part of the job.

The following versions remove some minor errors in the code in my prvious post, and also include the option to indent the output at each subfolder level. Use them in place of the ones I posted previously.

Public Sub DrawBough(sht As Worksheet, start_r As Long, start_c As Long, startfold As String, Indent As Boolean, DoSubs As Boolean)
'**********************************************************************
'  1. FUNCTIONAL DESCRIPTION of DrawBough
'
'     This sub draws a directory tree structure onto the active sheet, starting at
'     row start_R and columns Start_C on worksheet sht.
'     It draws the structure starting at startfold.
'     It is recursive, and will draw sub-folders if DoSubs is true.
'     If Indent is true, it will indent each sub-folder by one column wrt its parent.
'
'  2. REFERENCES - None
'
'  5. EXTERNAL EFFECTS
'     Draws a directory structure on the specified sheet, overwriting anything already there.
'
'**********************************************************************
'sht.Cells(start_r, start_c) = startfold
Dim colfolds As Collection
Dim colfiles As Collection
Dim thisitem As String
On Error Resume Next

'get the list of files and folders
thisitem = Dir(startfold, 31)
Set colfiles = New Collection
Set colfolds = New Collection

'this bit creates collections of the files and folders in this folder
While Err.Number = 0
    If thisitem <> "." And thisitem <> ".." And thisitem <> "" Then
        If (GetAttr(startfold & thisitem) And vbDirectory) Then
            colfolds.Add thisitem
        Else
            colfiles.Add thisitem
        End If
    End If
    thisitem = Dir()
Wend
Err.Clear

'draw the files in this folder
Dim f As Variant
Dim r As Long, c As Long
r = start_r
c = start_c
With sht
    For Each f In colfiles
        r = r + 1
        .Cells(r, c) = startfold & f
    Next f
End With
start_r = r

'draw the folders
If colfolds.count > 0 Then
    With sht
        'here is where to insert the DoSubs logic
        If DoSubs Then
            If Indent Then c = c + 1 'remove this line if not Indent to respond to the Indent logic
            For Each f In colfolds
                DrawBough sht, start_r, c, startfold & f & "\", Indent, DoSubs
            Next f
        End If
    End With
End If
End Sub

Public Sub AL_DrawTree()
'**********************************************************************
'  1. FUNCTIONAL DESCRIPTION of AL_DrawTree
'
'     This macro draws a directory tree structure onto the active sheet, starting at
'     the active cell.  It draws the structure starting at the folder selected by the user.
'
'  2. REFERENCES - None
'
'  3. INPUTS - None
'
'  4. OUTPUTS - None
'
'  5. EXTERNAL EFFECTS
'     Draws a directory structure on the active sheet, overwriting anything already there.
'**********************************************************************
'Decs
Dim sht As Worksheet
Dim r As Long, c As Long
Dim start_r As Long, start_c As Long
Dim initR As Long, initC As Long

Dim newline As String

'Note where starting
Set sht = ActiveSheet
start_r = ActiveCell.row
start_c = ActiveCell.Column
initR = start_r
initC = start_c + c

'Show a message warning the user of what will happen
Dim reply As Integer
Dim msg As String
newline = Chr(13)
msg = "This will draw a directory structure starting at the current cell: " _
    & newline & "(row" _
    & Str(start_r) _
    & ", column" _
    & Str(start_c) _
    & ", on sheet " & ActiveSheet.Name & ")" _
    & newline & "Do you want to continue?"
reply = MsgBox(msg, vbOKCancel, "Warning")
If reply = vbCancel Then Exit Sub

'get user start folder
Dim startfold As String
startfold = BrowseFolder("Select the folder from which you want the tree to be drawn.")

If startfold <> "" Then
    'User wants to continue so do so
    Dim CurrentRow As Long, CurrentCol As Long
    Dim MyRow As Long, MyCol As Long
    Dim Indent As Boolean, DoSubs As Boolean
    
    'search sub-folders?
    reply = MsgBox("Include Sub-Folders?", vbYesNo)
    DoSubs = (reply = vbYes)
    
    'indent the output?
    If DoSubs Then
      reply = MsgBox("Indent at each sub-folder level?", vbYesNo)
      Indent = (reply = vbYes)
    Else
      Indent = False
    End If
    
    'display a "wait" message
    Dim oldcolor As Long
    ActiveSheet.Cells(initR, initC + 1) = "Drawing the tree.  Please wait.  This message will disappear when the tree is complete."
    oldcolor = ActiveSheet.Cells(initR, initC + 1).Font.Color
    ActiveSheet.Cells(initR, initC + 1).Font.Color = RGB(255, 0, 0)
    
    'now do the actual drawing recursively
    DrawBough sht, start_r, start_c, startfold, Indent, DoSubs
    
    'clear the wait message, indicating the job is complete
    ActiveSheet.Cells(initR, initC + 1) = ""
    ActiveSheet.Cells(initR, initC + 1).Font.Color = oldcolor
End If
End Sub

Enjoy,

Tony