Click here to Skip to main content
Rate this: bad
good
Please Sign up or sign in to vote.
Hello everyone, I'm writing some code for a senior seminar as a business major, however I am not a strong programmer. The project involves me writing code in VBA that will go through a file directory, and produce line by line in the cells in excel the file paths for each file in the prescribed listing.
This is what I have so far, it creates a new page, however, so far I am not getting any output, but it throws no errors. It is currently enabled to only pull other .xls files for testing's sake.
 
If it helps at all, the file structure in question looks something like the following
 
'Documents' --> 'Ian's Stuff' --> 'Ian's Stuff' --> 'Business Seminar in IT' --> 'Business Seminar in IT Notes'
 

Option Explicit
Sub FullDir()
ActiveWorkbook.Sheets.Add
GetFiles "c:\documents\", ".xls"
End Sub
 
Sub GetFiles(strRootDir As String, Optional strType As String)
 
Dim strDirName As String
Dim bTypeMatch As Boolean
Dim colDirs As Collection
Dim lDirCounter As Long
Dim lIndex As Long
 
Set colDirs = New Collection
colDirs.Add strRootDir
lDirCounter = 1
lIndex = 2
 
'check for sub directories and make a recursive call to the lowest level dirs first

Do While lDirCounter <= colDirs.Count
strRootDir = colDirs(lDirCounter)
strDirName = Dir(strRootDir, vbDirectory + vbNormal)
Do While strDirName <> ""
If strDirName <> "." And strDirName <> ".." Then
If (GetAttr(strRootDir & strDirName) And vbDirectory) = vbDirectory Then
 
'add to the directories collection so that this will be done later

colDirs.Add strRootDir & strDirName & "\"
Else
 
'we found a normal file

bTypeMatch = False
If strType = "*.*" Then
bTypeMatch = True
ElseIf UCase(Right(strDirName, Len(strType))) = UCase(strType) Then
bTypeMatch = True
End If
If bTypeMatch = True Then
'we found a valid file

Cells(lIndex, 1) = strRootDir & strDirName
lIndex = lIndex + 1
End If
End If
End If
strDirName = Dir
Loop
lDirCounter = lDirCounter + 1
Loop
End Sub
Posted 20-Feb-13 6:20am
iGuy91112
Edited 20-Feb-13 6:25am
v2
Rate this: bad
good
Please Sign up or sign in to vote.

Solution 1

Below is a VBScript example of directory recursion that I developed. I put this file in my SENDTO directory so that I can right-click on a directory name and select this script file from the Send to context menu.
Option Explicit
 
'
' CreateDirectoryListing.VBS
' ===========================
'    Mike Meinz
'    11 Janury 2004
'
'
Const TemporaryFolder = 2
CONST THEFILENAME="_DirectoryListing.TXT"
Const MinWidth = 36
'
Dim objTempFolder 
Dim objArgs
Dim objLogFSO
Dim objLogFile
Dim wshShell
Dim strFileName
'
Sub ProcessItem(ByVal objItem, ByVal intMax)
Dim strAttr
strAttr = Space(4)
If objItem.Attributes And 1 Then
    strAttr = "R   " ' ReadOnly
End If
If objItem.Attributes And 2 Then
    strAttr=LEFT(strAttr, 1) & "H  " ' Hidden
End If
If objItem.Attributes And 4 Then
    strAttr=LEFT(strAttr, 2) & "S " ' System
End If
If objItem.Attributes And 32 Then
    strAttr=LEFT(strAttr,3) &  "A" ' Archive
End If
Call LogIt( _
    Left(objItem.Name & Space(intMax), intMax) & vbTab & _
    objItem.DateCreated & vbTab & _
    objItem.DateLastModified & vbTab & _
    objItem.Size & vbTab & _
    strAttr & vbTab & _
    objItem.Type, True)
End Sub
'
Sub ProcessFiles(ByVal strFolderSpec)
Dim objFSO
Dim objFolder
Dim objFileCollection
Dim objFolderCollection
Dim objItem
Dim objSubFolder
Dim strAttr
Dim intMax
Call LogIt(strFolderSpec, True)
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Err.Clear
Set objFolder = objFSO.GetFolder(strFolderSpec)
If Err.Number = 0 Then
    On Error GoTo 0
    Set objFileCollection = objFolder.Files
    For Each objItem In objFileCollection
        ' Determine Maximum FileName size
        If intMax < Len(objItem.Name) Then
            intMax = Len(objItem.Name)
        End If
    Next
    If intMax < MinWidth Then 
        intMax = MinWidth ' Minimum Size is MinWidth
    End If
    For Each objItem In objFileCollection
        Call ProcessItem(objItem, intMax)
    Next
    Call LogIt("", True)
    Set objFolderCollection = objFolder.SubFolders
    For Each objSubFolder In objFolderCollection
        Call ProcessFiles(objSubFolder.Path)
    Next
    Set objItem = Nothing
    Set objFileCollection = Nothing
    Set objSubFolder = Nothing
    Set objFolderCollection = Nothing
Else
    MsgBox "GetFolder Error" & vbNewLine & _
        Err.Description & "(" & Err.Number & ")" & vbNewLine & _
        strFolderSpec, vbCritical
    On Error GoTo 0
End If
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub
 
Sub LogIt(ByVal strMessage, ByVal bNewLine)
If bNewLine Then
    objLogFile.WriteLine strMessage
Else
    objLogFile.Write strMessage
End If
End Sub
'**********************************************************************
' Starts Here
'
Set objArgs = WScript.Arguments
Set objLogFSO = CreateObject("Scripting.FileSystemObject")
Set objTempFolder = objLogFSO.GetSpecialFolder(TemporaryFolder)
Set objLogFile = objTempFolder.CreateTextFile(THEFILENAME,True,True)
strFileName = objTempFolder.path & "\" & THEFILENAME
Call LogIt(Left("FileName" + Space(MinWidth), MinWidth) & vbTab & _
    LEFT("DateCreated"+SPACE(20),20) & vbTab & _
    LEFT("DateLastModified"+SPACE(20),20) & vbTab & _
    "Size" & vbTab & _
    "Attr" & vbTab & _
    "FileType", True)
Call ProcessFiles(objArgs(0))
objLogFile.Close
Set objLogFile = Nothing
Set wshShell = CreateObject("WScript.Shell")
wshShell.CurrentDirectory=objTempFolder.path
wshShell.Run ("Notepad.exe " & strFileName)
Set objTempFolder=Nothing
Set objLogFSO = Nothing
Set wshShell = Nothing
Set objArgs = Nothing
'
' Ends  here
'
  Permalink  
Comments
Maciej Los at 20-Feb-13 16:29pm
   
VBS <> VBA!
Mike Meinz at 20-Feb-13 16:31pm
   
Maciej Los - See Solution 2 - VBS easily migrated to VBA
Rate this: bad
good
Please Sign up or sign in to vote.

Solution 2

I modified the code from Solution 1 to search for ".xls" and to add to an Excel worksheet. The code below can be copied and pasted into an Excel Macro (ThisWorkBook).
 
Option Explicit
'
Dim lIndex
'
Private Sub ProcessItem(ByVal objItem, ByVal strFolderSpec As String)
'
' Adds a filename to the spreadsheet
'
' File Attributes are here in case you want to use them for something
'
Dim strAttr
strAttr = Space(4)
If objItem.Attributes And 1 Then
    strAttr = "R   " ' ReadOnly
End If
If objItem.Attributes And 2 Then
    strAttr = Left(strAttr, 1) & "H  " ' Hidden
End If
If objItem.Attributes And 4 Then
    strAttr = Left(strAttr, 2) & "S " ' System
End If
If objItem.Attributes And 32 Then
    strAttr = Left(strAttr, 3) & "A" ' Archive
End If
'
Cells(lIndex, 1) = strFolderSpec & "\" & objItem.Name
lIndex = lIndex + 1
'
End Sub
'
Private Sub ProcessFiles(ByVal strFolderSpec As String, ByVal strFilter As String)
'
' Processes directories and files in directories
'
Dim objFSO
Dim objFolder
Dim objFileCollection
Dim objFolderCollection
Dim objItem
Dim objSubFolder
Dim strAttr
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Err.Clear
Set objFolder = objFSO.GetFolder(strFolderSpec)
If Err.Number = 0 Then
    Err.Clear
    Set objFileCollection = objFolder.Files
    If Err.Number = 0 Then
        Err.Clear
        For Each objItem In objFileCollection
            If Not (IsEmpty(objItem)) Then ' Handles fact that some subfolders are not real subfolders
                'Debug.Print objItem.Name
                '
                ' Select only those that exactly match the filter
                '
                If LCase(Right(objItem.Name, Len(strFilter))) = LCase(strFilter) Then
                     Call ProcessItem(objItem, strFolderSpec)
                End If
            End If
        Next
    Else
        Debug.Print Err.Number & " " & Err.Message & " " & objFolder.Path
    End If
    On Error Resume Next
    Err.Clear
    Set objFolderCollection = objFolder.SubFolders
    If Err.Number = 0 Then
        Err.Clear
        For Each objSubFolder In objFolderCollection
            If Not (IsEmpty(objSubFolder)) Then ' Handles fact that some subfolders are not real subfolders
                'Debug.Print objSubFolder.Path
                '
                ' Process a subfolder
                '
                Call ProcessFiles(objSubFolder.Path, strFilter)
            End If
        Next
    Else
        Debug.Print Err.Number & " " & Err.Message & " " & objFolder.Path
    End If
    Set objItem = Nothing
    Set objFileCollection = Nothing
    Set objSubFolder = Nothing
    Set objFolderCollection = Nothing
Else
    MsgBox "GetFolder Error" & vbNewLine & _
        Err.Description & "(" & Err.Number & ")" & vbNewLine & _
        strFolderSpec, vbCritical
    On Error GoTo 0
End If
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub
 
Public Sub FullDir()
' Starts Here
'
lIndex = 2
ActiveWorkbook.Sheets.Add
Call ProcessFiles("C:\Users\<yourusername>\Documents", ".xls")
'
' Ends  here
'
End Sub
  Permalink  
v2
Comments
Maciej Los at 20-Feb-13 16:30pm
   
Do not multiply solution. Please, use "Improve solution" widget.
And read my comment to your first solution.
iGuy91 at 24-Feb-13 13:37pm
   
Yes! This is excellent! Exactly what I needed!
Thank you

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

  Print Answers RSS
0 OriginalGriff 278
1 Maciej Los 205
2 DamithSL 193
3 Nguyen.H.H.Dang 190
4 arvind mepani 187


Advertise | Privacy | Mobile
Web02 | 2.8.140709.1 | Last Updated 20 Feb 2013
Copyright © CodeProject, 1999-2014
All Rights Reserved. Terms of Service
Layout: fixed | fluid