Place the following code into the general declarations area of a bas module: --------------------------------------------------------------------------------
Public Declare Function FindFirstFile Lib "kernel32" _ Alias "FindFirstFileA" _ (ByVal lpFileName As String, _ lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" _ Alias "FindNextFileA" _ (ByVal hFindFile As Long, _ lpFindFileData As WIN32_FIND_DATA) As LongPublic Declare Function GetTickCount Lib "kernel32" () As Long '--end block--'
Form Code
Create a new project form similar to the illustration (from top to bottom, left to right): Text1, Text2, Frame1 containing three options buttons in a control array (Option1(0) - Option1(2) and one checkbox (Check2), Frame 2 containing five check boxes in a control array (Check1(0) - Check1(4), one command button (Command1). Below the frames is Text3 and List1. The code will set the captions for the controls. Add labels as needed, and add the following code to the form: --------------------------------------------------------------------------------
End Sub Private Sub Command1_Click() Dim fp As FILE_PARAMS Dim tstart As Single Dim tend As Single Dim nIndex As Long
'set flags indicating the scope of 'change desired, based on the option 'button selected nIndex = GetSelectedOptionIndex() fp.bChangeFileAttr = (nIndex = 0) Or (nIndex = 2) fp.bChangeFolderAttr = (nIndex = 1) Or (nIndex = 2)
'fill variable with the desired 'file attributes fp.nChangedAttr = 0 If Check1(0).Value = 1 Then fp.nChangedAttr = vbNormal If Check1(1).Value = 1 Then fp.nChangedAttr = fp.nChangedAttr Or vbReadOnly If Check1(2).Value = 1 Then fp.nChangedAttr = fp.nChangedAttr Or vbHidden If Check1(3).Value = 1 Then fp.nChangedAttr = fp.nChangedAttr Or vbSystem If Check1(4).Value = 1 Then fp.nChangedAttr = fp.nChangedAttr Or vbArchive
'set up the remaining File_Params With fp .sFileRoot = Text1.Text .sFileNameExt = Text2.Text .bRecurse = Check2.Value = 1 End With
'and do it. Since the files found are 'being added to the listbox, we toggle 'the list's visibility state to increase 'performance. In addition, GetTickCount 'returns the elapsed time for the operation. List1.Visible = False List1.Clear Text3.Text = ""
tstart = GetTickCount() Call SearchForFiles(fp)
tend = GetTickCount()
List1.Visible = True
'done - show the results Text3.Text = "Elapsed: " & FormatNumber((tend - tstart) / 1000, 2) & _ " seconds. Objects checked: " & FormatNumber(fp.checked, 0) & _ ". Changed: " & FormatNumber(fp.cnt, 0) & _ " (" & fp.sFileNameExt & ")" End Sub Private Function GetSelectedOptionIndex() As Long 'returns the selected item index from 'an option button array. Much cooler 'than multiple If...Then statements! 'If your array contains more elements, 'just append them to the test condition, 'setting the multiplier to the button's 'negative -index. GetSelectedOptionIndex = Option1(0).Value * 0 Or _ Option1(1).Value * -1 Or _ Option1(2).Value * -2 End Function Private Function GetFileInformation(fp As FILE_PARAMS) As Long 'local working variables Dim WFD As WIN32_FIND_DATA Dim hFile As Long Dim sPath As String Dim sRoot As String Dim sTmp As String Dim sExt As String
'FP.sFileRoot (assigned to sRoot) contains 'the path to search. ' 'FP.sFileNameExt (assigned to sPath) contains 'the full path and filespec. sRoot = QualifyPath(fp.sFileRoot) sPath = sRoot & fp.sFileNameExt
'obtain handle to the first filespec match hFile = FindFirstFile(sPath, WFD)
'if valid ... If hFile <> INVALID_HANDLE_VALUE Then Do
'Even though this routine uses filespecs, '*.* is still valid and will cause the search 'to return folders as well as files, so a 'check against folders is still required. If Not (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _ = FILE_ATTRIBUTE_DIRECTORY Then
'if changing the file atrributes, 'remove trailing nulls, add to list 'and add to total count If fp.bChangeFileAttr Then
'this tracks how many items were changed fp.cnt = fp.cnt + 1
End If
'this tracks how many items were examined fp.checked = fp.checked + 1
End If
Loop While FindNextFile(hFile, WFD)
'close handle hFile = FindClose(hFile)
End If
End Function Public Function TrimNull(startstr As String) As String 'returns the string up to the first 'null, if present, or the passed string
Dim pos As Integer
pos = InStr(startstr, Chr$(0))
If pos Then TrimNull = Left$(startstr, pos - 1) Exit Function End If
TrimNull = startstr
End Function
Private Sub SearchForFiles(fp As FILE_PARAMS) 'local working variables Dim WFD As WIN32_FIND_DATA Dim hFile As Long Dim sPath As String Dim sRoot As String
'this method uses *.* to locate everything. 'The GetFileInformation routine uses the 'file extension specified in its search. 'This allows retrieval of folders as well 'as the specified file type. sRoot = QualifyPath(fp.sFileRoot) sPath = sRoot & "*.*"
'obtain handle to the first match hFile = FindFirstFile(sPath, WFD)
'if valid ... If hFile <> INVALID_HANDLE_VALUE Then
'This is where the method obtains the file 'list and data for the folder passed. Call GetFileInformation(fp) Do
'if the returned item is a folder If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _ = FILE_ATTRIBUTE_DIRECTORY Then
'if the Recurse flag was specified If fp.bRecurse Then
'this checks that the first char in the 'filename is not one of the system special 'folders (. or ..) before performing recursion If Asc(WFD.cFileName) <> vbDot Then
'found a folder, it is not one to 'the two system folder types, so 'begin a recursive search of it
'continue loop until no more matches Loop While FindNextFile(hFile, WFD)
'close the handle hFile = FindClose(hFile)
End If
End Sub Private Function QualifyPath(sPath As String) As String 'assures passed path ends in a slash
If Right$(sPath, 1) <> "\" Then QualifyPath = sPath & "\" Else: QualifyPath = sPath End If
End Function '--end block--'
Comments Before running, assure that you specify a valid drive, path and filespec in text boxes. --------------------------------------------------------------------------------
Place the following code into the general declarations area of a bas module: --------------------------------------------------------------------------------
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you can not publish
' or reproduce this code on any web site,
' on any online service, or distribute on
' any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const MAXDWORD As Long = &HFFFFFFFF
Public Const MAX_PATH As Long = 260
Public Const INVALID_HANDLE_VALUE As Long = -1
Public Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Public Const FILE_ATTRIBUTE_READONLY As Long = &H1
Public Const FILE_ATTRIBUTE_HIDDEN As Long = &H2
Public Const FILE_ATTRIBUTE_SYSTEM As Long = &H4
Public Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Public Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
Public Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100
Public Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End TypePublic Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type'custom UDT for searching
Public Type FILE_PARAMS
bRecurse As Boolean 'set True to perform recursive search
sFileRoot As String 'search starting point, ie c:\, c:\winnt\
sFileNameExt As String 'filename/filespec to locate, ie *.*
bChangeFileAttr As Boolean 'new - flag set when Files specified
bChangeFolderAttr As Boolean 'new - flag set when Folders specified
nChangedAttr As Long 'new - new attribute for files/folders
checked As Long 'new - total files examined
cnt As Long 'total file count matching filespec
End TypePublic Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Public Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As LongPublic Declare Function GetTickCount Lib "kernel32" () As Long
'--end block--'
Form Code
Create a new project form similar to the illustration (from top to bottom, left to right): Text1, Text2, Frame1 containing three options buttons in a control array (Option1(0) - Option1(2) and one checkbox (Check2), Frame 2 containing five check boxes in a control array (Check1(0) - Check1(4), one command button (Command1). Below the frames is Text3 and List1. The code will set the captions for the controls. Add labels as needed, and add the following code to the form: --------------------------------------------------------------------------------
Option ExplicitPrivate Const vbDot = 46Private Sub Form_Load() Option1(0).Caption = "Files Only"
Option1(1).Caption = "Folders Only"
Option1(2).Caption = "Both Files and Folders"
Check1(0).Caption = "Normal"
Check1(1).Caption = "Read Only"
Check1(2).Caption = "Hidden"
Check1(3).Caption = "System"
Check1(4).Caption = "Archive"
Option1(0).Value = True
Check1(0).Value = 1
Command1.Caption = "Change"
End Sub
Private Sub Command1_Click() Dim fp As FILE_PARAMS Dim tstart As Single
Dim tend As Single
Dim nIndex As Long
'set flags indicating the scope of
'change desired, based on the option
'button selected
nIndex = GetSelectedOptionIndex()
fp.bChangeFileAttr = (nIndex = 0) Or (nIndex = 2)
fp.bChangeFolderAttr = (nIndex = 1) Or (nIndex = 2)
'fill variable with the desired
'file attributes
fp.nChangedAttr = 0
If Check1(0).Value = 1 Then fp.nChangedAttr = vbNormal
If Check1(1).Value = 1 Then fp.nChangedAttr = fp.nChangedAttr Or vbReadOnly
If Check1(2).Value = 1 Then fp.nChangedAttr = fp.nChangedAttr Or vbHidden
If Check1(3).Value = 1 Then fp.nChangedAttr = fp.nChangedAttr Or vbSystem
If Check1(4).Value = 1 Then fp.nChangedAttr = fp.nChangedAttr Or vbArchive
'set up the remaining File_Params
With fp
.sFileRoot = Text1.Text
.sFileNameExt = Text2.Text
.bRecurse = Check2.Value = 1
End With
'and do it. Since the files found are
'being added to the listbox, we toggle
'the list's visibility state to increase
'performance. In addition, GetTickCount
'returns the elapsed time for the operation.
List1.Visible = False
List1.Clear
Text3.Text = ""
tstart = GetTickCount() Call SearchForFiles(fp)
tend = GetTickCount()
List1.Visible = True
'done - show the results
Text3.Text = "Elapsed: " & FormatNumber((tend - tstart) / 1000, 2) & _
" seconds. Objects checked: " & FormatNumber(fp.checked, 0) & _
". Changed: " & FormatNumber(fp.cnt, 0) & _
" (" & fp.sFileNameExt & ")"
End Sub
Private Function GetSelectedOptionIndex() As Long 'returns the selected item index from
'an option button array. Much cooler
'than multiple If...Then statements!
'If your array contains more elements,
'just append them to the test condition,
'setting the multiplier to the button's
'negative -index.
GetSelectedOptionIndex = Option1(0).Value * 0 Or _
Option1(1).Value * -1 Or _
Option1(2).Value * -2
End Function
Private Function GetFileInformation(fp As FILE_PARAMS) As Long 'local working variables
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
Dim sPath As String
Dim sRoot As String
Dim sTmp As String
Dim sExt As String
'FP.sFileRoot (assigned to sRoot) contains
'the path to search.
'
'FP.sFileNameExt (assigned to sPath) contains
'the full path and filespec.
sRoot = QualifyPath(fp.sFileRoot)
sPath = sRoot & fp.sFileNameExt
'obtain handle to the first filespec match
hFile = FindFirstFile(sPath, WFD)
'if valid ...
If hFile <> INVALID_HANDLE_VALUE Then Do
'Even though this routine uses filespecs,
'*.* is still valid and will cause the search
'to return folders as well as files, so a
'check against folders is still required.
If Not (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
= FILE_ATTRIBUTE_DIRECTORY Then
'if changing the file atrributes,
'remove trailing nulls, add to list
'and add to total count
If fp.bChangeFileAttr Then
sTmp = TrimNull(WFD.cFileName)
SetAttr sRoot & sTmp, fp.nChangedAttr
List1.AddItem sRoot & sTmp
'this tracks how many items were changed
fp.cnt = fp.cnt + 1
End If
'this tracks how many items were examined
fp.checked = fp.checked + 1
End If
Loop While FindNextFile(hFile, WFD)
'close handle
hFile = FindClose(hFile)
End If
End Function
Public Function TrimNull(startstr As String) As String 'returns the string up to the first
'null, if present, or the passed string
Dim pos As Integer
pos = InStr(startstr, Chr$(0))
If pos Then
TrimNull = Left$(startstr, pos - 1)
Exit Function
End If
TrimNull = startstr
End Function
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
Dim sPath As String
Dim sRoot As String
'this method uses *.* to locate everything.
'The GetFileInformation routine uses the
'file extension specified in its search.
'This allows retrieval of folders as well
'as the specified file type.
sRoot = QualifyPath(fp.sFileRoot)
sPath = sRoot & "*.*"
'obtain handle to the first match
hFile = FindFirstFile(sPath, WFD)
'if valid ...
If hFile <> INVALID_HANDLE_VALUE Then
'This is where the method obtains the file
'list and data for the folder passed.
Call GetFileInformation(fp) Do
'if the returned item is a folder
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
= FILE_ATTRIBUTE_DIRECTORY Then
'if the Recurse flag was specified
If fp.bRecurse Then
'this checks that the first char in the
'filename is not one of the system special
'folders (. or ..) before performing recursion
If Asc(WFD.cFileName) <> vbDot Then
'found a folder, it is not one to
'the two system folder types, so
'begin a recursive search of it
'remove trailing nulls and assign
'new search path
fp.sFileRoot = sRoot & TrimNull(WFD.cFileName)
Call SearchForFiles(fp)
End If 'If Asc
End If 'If fp.bRecurse
'if changing folder attributes do it now.
'This assures changes won't prevent methods
'from examining subfolders.
If fp.bChangeFolderAttr Then
'prevent the attribute from being
'set every time the loop executes.
If Not (GetAttr(fp.sFileRoot) And fp.nChangedAttr) = fp.nChangedAttr Then
SetAttr fp.sFileRoot, fp.nChangedAttr
List1.AddItem fp.sFileRoot
fp.cnt = fp.cnt + 1
End If
End If
fp.checked = fp.checked + 1
End If 'If (WFD.dwFileAttributes
'continue loop until no more matches
Loop While FindNextFile(hFile, WFD)
'close the handle
hFile = FindClose(hFile)
End If
End Sub
Private Function QualifyPath(sPath As String) As String 'assures passed path ends in a slash
If Right$(sPath, 1) <> "\" Then
QualifyPath = sPath & "\"
Else: QualifyPath = sPath
End If
End Function
'--end block--'
Comments
Before running, assure that you specify a valid drive, path and filespec in text boxes. --------------------------------------------------------------------------------