Code:
Option Compare Database
Option Explicit
Dim strFileName As String
Dim StackArr() As String
Dim StackEntry As String
Dim strPosition As Long
Dim I As Integer
Dim idx As Integer
Dim FileCount As Long
Dim Exclusions() As String
Private Sub Form_Open(Cancel As Integer)
Me.tbExclusions = "C:\Windows\; C:\Program Files\; C:\Program Files (x86)\" ' Initialize the default set of exclusions
End Sub
Private Sub DirTreeCrawler_Click()
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
' This app employs a FIFO stack to traverse the entire folder tree starting with the path
' expression entered in the text box "tbRootExp". The format of the root expression is
' of the form: drive:\[folder name1\][folder name2\][folder name3\]........[folder namen\]
'
' As each folder/sub-folder name is encountered via the VBA Dir command, it is put on the
' stack via the function "Push". When the contents of the current folder have been examined,
' the loop ends and the next folder to be examined is obtained via the "Pop" function.
' Proceeding in this method results in the examination of the entire folder tree. (And
' yes, one can process an entire disc.)
'
' Bill Stanton - May 19, 2014 (a.k.a. GraeagleBill)
'*=*=*=*=*=*=(Current implementation)*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
' The current app shown here is looking for errant files that resulted from a Win 7 Windows
' Explorer copy/paste operation of large amounts of folders/sub-folders and the contained
' files. Example: the file MyTextFile.txt~MyTextFile was created in addition to the intended
' file, MyTextFile.txt. There were literally thousands of such files created. This app finds
' and deletes all such files found within the specified directory tree.
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
On Error GoTo DirError
If IsNull(Me.tbRootExp) Then
MsgBox "Please specify starting directory," & vbNewLine _
& "as there isn't any default."
Exit Sub
End If
If Not IsNull(Me.tbExclusions) Then
Exclusions = Split(Me.tbExclusions, ";") ' Load whatever exclusions are to be in effect
Else
Exclusions = Split("NONE") ' Have at least one array element
End If
FileCount = 0 ' Container for the number of files deleted
ReDim StackArr(0) ' Initialize stack array to a single element
Push ("IsEmpty") ' Initialze stack with terminating directory expression
StackEntry = tbRootExp ' Start as though we just popped a directory name off the stack
Do Until StackEntry = "IsEmpty"
strFileName = Dir(StackEntry, vbDirectory) ' Wanting file names or names of sub-directories
Do While strFileName <> ""
If Not (strFileName = "." Or strFileName = "..") Then ' Entries to ignore
If InStr(strFileName, ".") = 0 Then
Push (StackEntry & strFileName & "\") ' Append sub-folder name and put dir expression on the stack
Else
Call FileDisposition
End If
End If
strFileName = Dir ' Can be a file name or a sub-directory name
Loop
StackEntry = Pop()
Loop
MsgBox "Traversing completed. " & FileCount & " Files deleted."
Exit Sub
DirError:
MsgBox "Directory Crawler has encountered the following error:" & vbNewLine _
& Err.Description & vbNewLine _
& "The accompanying error code is: " & Err.Number
Exit Sub
End Sub
Private Sub FileDisposition()
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
' It is in this sub that anything specific about the current file is handled. The file
' name is strFileName and is contained in the fully qualified folder path, StackEntry.
' Both those values have global scope herein.
'
'*=*=*=*=*=*=(The disposition)=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
' We're looking here to delete the errant files described earlier. The code here can be
' completely replaced if other dispositions of the current file are being considered.
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
strPosition = InStr(strFileName, "~")
If strPosition > 0 Then 'Our tell-tell character present in current file name?
If strPosition > 5 And Mid(strFileName, strPosition - 4, 1) = "." Then ' Sub-string of the form ".xxx~"
Kill (StackEntry & strFileName)
FileCount = FileCount + 1
End If
End If
End Sub
Private Function Push(LastIn As String) As String
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
' If the "LastIn" folder isn't found in the exclusions list, re-dimension the stack array
' to provide for a single addition to the stack.
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
For I = 0 To UBound(Exclusions)
If LastIn = Trim(Exclusions(I)) Then Exit Function
Next I
idx = UBound(StackArr) + 1
ReDim Preserve StackArr(idx)
StackArr(idx) = LastIn
End Function
Private Function Pop() As String
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
' Set the returned value to the last element on the stack. Then, re-dimension the array
' (Stack) to reflect the removable of the last element. (VBA doesn't provide for an
' automatic "throw away" of trailing elements if a "ReDim" reduces its original size, so
' it becomes necessary to copy to a temporary array then copy the elements back to the
' newly re-dimensioned array.)
'
' Note that the code is insensitive to an empty array in the current application, as the
' stack contains a terminating expression as its first element.
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Dim TmpStackArr() As String ' We need a temporary array in the course of reducing size of our stack
idx = UBound(StackArr)
Pop = StackArr(idx) ' Last in, First out: (last element of the Stack array.)
If StackArr(idx) <> "IsEmpty" Then ' Only necessary to perform the copy operation if there
' are more stack entries to process
ReDim TmpStackArr(UBound(StackArr) - 1) ' Temporary array one element less than the stack.
For I = 0 To UBound(StackArr) - 1 ' Copy remaining stack entries to temporary array
TmpStackArr(I) = StackArr(I)
Next I
StackArr = TmpStackArr ' Now, move the entries back thereby updating the remaining stack
End If
End Function