Dir function to loop through folders

[tad0075]

I'm having trouble getting a loop involving the Dir(filepath, vbDirectory) to work cleanly. Problem is the "." and ".." results for the old DOS shortcut to current and parent directory. I can ignore those results just fine, but either I get caught in an infinite loop or get kicked out of the loop because the function won't move past this result. When I'm pulling folders, my function is copying files out of them, and when it's done I kill the empty folder. As long as it's only pulling subfolders, the code will move through each folder, do its work, and move to the next one until the folder is empty.

Any ideas for forcing the code to ignore the "." and ".." results when pulling folder names?

Thanks,
Tyler

Public Function GetPictures()

Dim OrigLocation As String
Dim NewLocation As String
Dim Folder As String
Dim PicName As String
Dim AppendSQL As String

OrigLocation = "(filepath removed)"
NewLocation = "(filepath removed)"

Folder = Dir(OrigLocation, vbDirectory)

Do While Folder <> ""
    If Folder <> "." And Folder <> ".." Then
       
        'Make sure it's a directory
        If (GetAttr(OrigLocation & Folder) And vbDirectory) = vbDirectory Then
            PicName = Dir(OrigLocation & Folder & "/*.JPG")
            Do While PicName <> ""
                AppendSQL = "INSERT INTO [Picture Import Log] ( DateTaken, PictureName, DateImported, NewPath )" & _
                    "SELECT CDate(" & Folder & "), '" & PicName & "', Date(), '" & NewLocation & PicName & "';"
                DoCmd.RunSQL AppendSQL
                retval = 0
                Set objFSO = CreateObject("Scripting.FileSystemObject")
                retval = objFSO.CopyFile(OrigLocation & Folder & "\" & PicName, NewLocation & PicName, True)
                Set objFSO = Nothing
                Kill OrigLocation & Folder & "\" & PicName
                PicName = Dir(OrigLocation & Folder & "/*.JPG")
            Loop
            RmDir OrigLocation & Folder & "\"
        End If

    End If
    Folder = Dir(OrigLocation, vbDirectory)
Loop

End Function

 

[Rx_]

A while back, I had thousands of Excel Templet workbooks with varying amounts of worksheets each. They were each stored in a folder with other objects pertaining to a site. Years of data.

This is what I used to open each folder. I don't have much time at the moment, so you will probably find another subroutine that is called somewhere in this example. That subroutine validated the Excel workbook meets the criteria, then harvested each tab's data into a SQL Server.

In general, this should help you with some code sample? Give me a thanks if it helps.

' open file API call [URL]http://access.mvps.org/access/api/api0001.htm[/URL]
 
'1.Create a new form.
'2.Add a list box, and set these properties:
    'Name              lstFileList
   ' Row Source Type   Value List
'3.Set the On Load property of the form to:
    '[Event Procedure]
'4.Click the Build button (...) beside this. Access opens the code window. Set up the event procedure like this:
    'Private Sub Form_Load()
        'Call ListFiles("C:\Data", , , Me.lstFileList)
    'End Sub
' To list the files in C:\Data, open the Immediate Window (Ctrl+G), and enter:
    'Call ListFiles("C:\Data")
'To limit the results to Excel files:
    'Call ListFiles("C:\MyFolder\MySubFolder\", "*.xls*")
 
 
 
'----------------------------------------------------------------------
Public Sub FillTableWithFiles()
      Dim MyFoldername As String
10    On Error GoTo ErrorTrap
20    MyFoldername = InputBox("Please enter the Path for the top level folder", "Starting Folder", "M:\Operations\Environmental")
      ' starting path for harvest
      If MyFoldername = "" Then Exit Sub
30    Call ListFiles(MyFoldername, "*.xls*", True)
40    Exit Sub
ErrorTrap:
50     MsgBox "An error occured: " & Err.Description, vbCritical, "Error Message during process - Please take note"
End Sub
 
Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
    Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
10    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.
          '           lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window.
          '               The list box must have its Row Source Type property set to Value List.
          'Method:    FilDir() adds items to a collection, calling itself recursively for subfolders.
          Dim colDirList As New Collection
          Dim varItem As Variant
 
20        Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
 
          'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window.
30        If lst Is Nothing Then
40            For Each varItem In colDirList
50                Debug.Print varItem
60                'ProcessExcelFile strPath, CStr(varItem) ' This may have been on the orginal Harvest Access application
70                DoEvents
80            Next
90        Else
100           For Each varItem In colDirList
110           lst.AddItem varItem
120           DoEvents
130           Next
140       End If
Exit_Handler:
150       Exit Function
err_handler:
160       MsgBox "Error " & Err.Number & ": " & Err.Description
170       Resume Exit_Handler
End Function
Private Function FillDir(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
          Dim strTemp As String
          Dim colFolders As New Collection
          Dim vFolderName As Variant
          'Add the files to the folder.
10        strFolder = TrailingSlash(strFolder)
20        strTemp = Dir(strFolder & strFileSpec)
30        Do While strTemp <> vbNullString
40            colDirList.Add strFolder & strTemp
50            strTemp = Dir
60        Loop
70        If bIncludeSubfolders Then
              'Build collection of additional subfolders.
80            strTemp = Dir(strFolder, vbDirectory)
90            Do While strTemp <> vbNullString
100               If (strTemp <> ".") And (strTemp <> "..") Then
110                   If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
120                       colFolders.Add strTemp
130                   End If
140               End If
150               strTemp = Dir
160           Loop
              'Call function recursively for each subfolder.
170           For Each vFolderName In colFolders
180               Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
190           Next vFolderName
200       End If
End Function
Public Function TrailingSlash(varIn As Variant) As String
10        If Len(varIn) > 0& Then
20            If Right(varIn, 1&) = "\" Then
30                TrailingSlash = varIn
40            Else
50                TrailingSlash = varIn & "\"
60            End If
70        End If
End Function

 

[jdraw]

Can you alter your Do while Folder <> ""

along these lines?

Do while (Folder <>"" and Folder <> "." and Folder <> ".." )

There are related techniques at
http://allenbrowne.com/ser-59.html
http://allenbrowne.com/ser-59alt.html

Good luck.

Oooops: I see Rx has responded.

 

[tad0075]

Thanks guys. I actually just ended up putting in a counter that kicks out of the loop if it pulls "." or ".." too many times. The filters were working just fine, but these 2 results were pulling infinitely after the subfolders were all processed.

Modified code:

Public Function GetPictures()

Dim OrigLocation As String
Dim NewLocation As String
Dim Folder As String
Dim PicName As String
Dim PicDate As Date
Dim AppendSQL As String
Dim Count As Integer

OrigLocation = "(filepath removed)"
NewLocation = "(filepath removed)"
Folder = Dir(OrigLocation, vbDirectory)
Count = 0

Do While Folder <> "" And Count < 1000
    If Folder <> "." And Folder <> ".." Then

       
        'Make sure it's a directory
        If (GetAttr(OrigLocation & Folder) And vbDirectory) = vbDirectory Then
            PicDate = CDate(Folder)
            PicName = Dir(OrigLocation & Folder & "\*.JPG")
            Do While PicName <> ""
                DoCmd.SetWarnings False
                AppendSQL = "INSERT INTO [Picture Import Log] ( DateTaken, PictureName, DateImported, NewPath )" & _
                    "SELECT #" & PicDate & "#, Left('" & PicName & "',Len('" & PicName & "')-4), Date(), '" & NewLocation & PicName & "';"
                DoCmd.RunSQL AppendSQL
                DoCmd.SetWarnings True
                retval = 0
                Set objFSO = CreateObject("Scripting.FileSystemObject")
                retval = objFSO.CopyFile(OrigLocation & Folder & "\" & PicName, NewLocation & PicName, True)
                Set objFSO = Nothing
                Kill OrigLocation & Folder & "\" & PicName
                PicName = Dir(OrigLocation & Folder & "\*.JPG")
            Loop
            RmDir OrigLocation & Folder & "\"
        End If
        
    Folder = Dir(OrigLocation, vbDirectory)
    Else
    Count = Count + 1
    Folder = Dir
    End If
Loop

End Function

Thanks,
Tyler