Expert: Robert Nunemaker - 2/24/2006

Question
Dear sir,

I want a VB Code which searches for a file on all drives(including folders and subfolders) and display all the duplicates along with the path in a listbox.

Important : The program should work both for hidden files as well as unhidden files.

Take for eg, read.txt. Assume it is available in the path c:\sample. Assume it is also available in the path d:\example. Now, the program should search for the file "read.txt" given in a text box and should display the following paths in the listbox when a command button is pressed.

c:\sample
d:\example

Important : The program should work both for hidden files as well as unhidden files.

Thanks.
S.Anand

Answer
You can of course use the File System Object and call it recursively.  But it's 5X or more slower than using the system API's.  Below is code to do this search as well as code for your test form.  It may seem a bit complicated, but your users will thank you for making it efficient.  Searching for a single file on a typical computer will usually take less than a minute with this technique.

Hope this helps.  Good Luck!

Test Project - save the following into prjFileSearch.vbp:
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\WINDOWS\system32\STDOLE2.TLB#OLE Automation
Form=frmSearchForFiles.frm
Startup="frmSearchForFiles"
Command32=""
Name="prjFileSearch"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

[MS Transaction Server]
AutoRefresh=1

~~~~~~~~~~~~~~~~~~~'

Test Form - save the following into frmSearchForFiles.frm:
VERSION 5.00
Begin VB.Form frmSearchForFiles
  Caption         =   "File Search"
  ClientHeight    =   4305
  ClientLeft      =   60
  ClientTop       =   450
  ClientWidth     =   6495
  LinkTopic       =   "Form1"
  ScaleHeight     =   4305
  ScaleWidth      =   6495
  StartUpPosition =   3  'Windows Default
  Begin VB.CheckBox chkRecursive
     Alignment       =   1  'Right Justify
     Caption         =   "Recursive?"
     Height          =   255
     Left            =   5040
     TabIndex        =   8
     Top             =   1200
     Width           =   1215
  End
  Begin VB.ListBox lstLocations
     Height          =   2400
     Left            =   240
     TabIndex        =   7
     Top             =   1800
     Width           =   6015
  End
  Begin VB.TextBox txtFolder
     Height          =   285
     Left            =   240
     TabIndex        =   3
     Top             =   360
     Width           =   4215
  End
  Begin VB.CommandButton cmdSearch
     Caption         =   "&Search"
     Height          =   375
     Left            =   240
     TabIndex        =   2
     Top             =   1200
     Width           =   1815
  End
  Begin VB.TextBox txtFilename
     Height          =   285
     Left            =   4680
     TabIndex        =   0
     Top             =   360
     Width           =   1575
  End
  Begin VB.Label lblTime
     BackStyle       =   0  'Transparent
     Caption         =   "Total Time:"
     Height          =   255
     Left            =   4680
     TabIndex        =   6
     Top             =   840
     Width           =   1575
  End
  Begin VB.Label lblTotal
     BackStyle       =   0  'Transparent
     Caption         =   "Total Found: "
     Height          =   255
     Left            =   240
     TabIndex        =   5
     Top             =   840
     Width           =   4215
  End
  Begin VB.Label lblFolder
     AutoSize        =   -1  'True
     BackStyle       =   0  'Transparent
     Caption         =   "Folder to start in..."
     Height          =   195
     Left            =   240
     TabIndex        =   4
     Top             =   120
     Width           =   1260
  End
  Begin VB.Label lblFilename
     AutoSize        =   -1  'True
     BackStyle       =   0  'Transparent
     Caption         =   "Filename"
     Height          =   195
     Left            =   4680
     TabIndex        =   1
     Top             =   120
     Width           =   630
  End
End
Attribute VB_Name = "frmSearchForFiles"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Const vbDot = 46
Private Const MAXDWORD As Long = &HFFFFFFFF
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Private 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

Private Type FILE_PARAMS
  bRecurse As Boolean
  sFileRoot As String
  sFileNameExt As String
  sResult As String
  sMatches As String
  Count As Long
End Type

Private Declare Function FindClose Lib "kernel32" _
 (ByVal hFindFile As Long) As Long
  
Private Declare Function FindFirstFile Lib "kernel32" _
  Alias "FindFirstFileA" _
 (ByVal lpFileName As String, _
  lpFindFileData As WIN32_FIND_DATA) As Long
  
Private Declare Function FindNextFile Lib "kernel32" _
  Alias "FindNextFileA" _
 (ByVal hFindFile As Long, _
  lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Sub cmdSearch_Click()

  Dim FP As FILE_PARAMS  'holds search parameters
  Dim tstart As Single   'timer var for this routine only
  Dim tend As Single     'timer var for this routine only
  
  ' Filename provided?
  If Trim$(txtFilename.Text) = "" Then
     MsgBox "Please enter a filename to search for.  Wildcard characters of ? and * may be used.", vbCritical + vbOKOnly, "Please provide filename..."
     Exit Sub
  End If

  ' Folder provided?
  If Trim$(txtFolder.Text) = "" Then
     txtFolder.Text = "C:\"
  End If

  Me.MousePointer = vbHourglass
 
 'setting the list visibility to false
 'increases the load time
 lblTotal.Caption = ""
 lstLocations.Clear
 lstLocations.Visible = False
  
 'set up search params
  With FP
     .sFileRoot = txtFolder.Text       'start path
     .sFileNameExt = txtFilename.Text    'file type of interest
     .bRecurse = chkRecursive.Value = 1  '1 = recursive search
  End With
  
 'get start time, get files, and get finish time
  tstart = GetTickCount()
  Call SearchForFiles(FP)
  tend = GetTickCount()
  
  lstLocations.Visible = True
  
 'show the results
  lblTotal.Caption = Format$(FP.Count, "###,###,###,##0") & _
                       " found (" & _
                       FP.sFileNameExt & ")"
                  
  lblTime.Caption = FormatNumber((tend - tstart) / 1000, 2) & "  seconds"
                                   
  Me.MousePointer = vbNormal

End Sub


Private Sub GetFileInformation(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
  Dim sTmp As String
     
 'FP.sFileRoot contains the path to search.
 'FP.sFileNameExt 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 file specs,
       '*.* 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

          'this is where you add code to store
          'or display the returned file listing.
          '
          'if you want the file name only, save 'sTmp'.
          'if you want the full path, save 'sRoot & sTmp'

          'remove trailing nulls
           FP.Count = FP.Count + 1
           sTmp = TrimNull(WFD.cFileName)
          lstLocations.AddItem sRoot & sTmp

        End If
        Me.refresh: DoEvents
     Loop While FindNextFile(hFile, WFD)
     
     
    'close the handle
     hFile = FindClose(hFile)
  
  End If

End Sub

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
  Dim sTmp As String
     
  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) Then
           
          '..and the Recurse flag was specified
           If FP.bRecurse Then
           
             'and if the folder is not the default
             'self and parent folders (a . or ..)
              If Asc(WFD.cFileName) <> vbDot Then
              
                '..then the item is a real folder, which
                'may contain other sub folders, so assign
                'the new folder name to FP.sFileRoot and
                'recursively call this function again with
                'the amended information.

                'remove trailing nulls
                 FP.sFileRoot = sRoot & TrimNull(WFD.cFileName)
                 Call SearchForFiles(FP)
                 
              End If
              
           End If
           
        End If
        
    'continue looping until FindNextFile returns
    '0 (no more matches)
     Loop While FindNextFile(hFile, WFD)
     
    'close the find handle
     hFile = FindClose(hFile)
  
  End If
  
End Sub

Private Function QualifyPath(sPath As String) As String

 'assures that a passed path ends in a slash
  If Right$(sPath, 1) <> "\" Then
     QualifyPath = sPath & "\"
  Else
     QualifyPath = sPath
  End If
     
End Function


Private 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

~~~~~~~~~~~~~~~~~~~~~~~~

Test code - open the project, double-click the form, and paste this code:
VERSION 5.00
Begin VB.Form frmSearchForFiles
  Caption         =   "File Search"
  ClientHeight    =   4305
  ClientLeft      =   60
  ClientTop       =   450
  ClientWidth     =   6495
  LinkTopic       =   "Form1"
  ScaleHeight     =   4305
  ScaleWidth      =   6495
  StartUpPosition =   3  'Windows Default
  Begin VB.CheckBox chkRecursive
     Alignment       =   1  'Right Justify
     Caption         =   "Recursive?"
     Height          =   255
     Left            =   5040
     TabIndex        =   8
     Top             =   1200
     Width           =   1215
  End
  Begin VB.ListBox lstLocations
     Height          =   2400
     Left            =   240
     TabIndex        =   7
     Top             =   1800
     Width           =   6015
  End
  Begin VB.TextBox txtFolder
     Height          =   285
     Left            =   240
     TabIndex        =   3
     Top             =   360
     Width           =   4215
  End
  Begin VB.CommandButton cmdSearch
     Caption         =   "&Search"
     Height          =   375
     Left            =   240
     TabIndex        =   2
     Top             =   1200
     Width           =   1815
  End
  Begin VB.TextBox txtFilename
     Height          =   285
     Left            =   4680
     TabIndex        =   0
     Top             =   360
     Width           =   1575
  End
  Begin VB.Label lblTime
     BackStyle       =   0  'Transparent
     Caption         =   "Total Time:"
     Height          =   255
     Left            =   4680
     TabIndex        =   6
     Top             =   840
     Width           =   1575
  End
  Begin VB.Label lblTotal
     BackStyle       =   0  'Transparent
     Caption         =   "Total Found: "
     Height          =   255
     Left            =   240
     TabIndex        =   5
     Top             =   840
     Width           =   4215
  End
  Begin VB.Label lblFolder
     AutoSize        =   -1  'True
     BackStyle       =   0  'Transparent
     Caption         =   "Folder to start in..."
     Height          =   195
     Left            =   240
     TabIndex        =   4
     Top             =   120
     Width           =   1260
  End
  Begin VB.Label lblFilename
     AutoSize        =   -1  'True
     BackStyle       =   0  'Transparent
     Caption         =   "Filename"
     Height          =   195
     Left            =   4680
     TabIndex        =   1
     Top             =   120
     Width           =   630
  End
End
Attribute VB_Name = "frmSearchForFiles"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Const vbDot = 46
Private Const MAXDWORD As Long = &HFFFFFFFF
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Private 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

Private Type FILE_PARAMS
  bRecurse As Boolean
  sFileRoot As String
  sFileNameExt As String
  sResult As String
  sMatches As String
  Count As Long
End Type

Private Declare Function FindClose Lib "kernel32" _
 (ByVal hFindFile As Long) As Long
  
Private Declare Function FindFirstFile Lib "kernel32" _
  Alias "FindFirstFileA" _
 (ByVal lpFileName As String, _
  lpFindFileData As WIN32_FIND_DATA) As Long
  
Private Declare Function FindNextFile Lib "kernel32" _
  Alias "FindNextFileA" _
 (ByVal hFindFile As Long, _
  lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Sub cmdSearch_Click()

  Dim FP As FILE_PARAMS  'holds search parameters
  Dim tstart As Single   'timer var for this routine only
  Dim tend As Single     'timer var for this routine only
  
  ' Filename provided?
  If Trim$(txtFilename.Text) = "" Then
     MsgBox "Please enter a filename to search for.  Wildcard characters of ? and * may be used.", vbCritical + vbOKOnly, "Please provide filename..."
     Exit Sub
  End If

  ' Folder provided?
  If Trim$(txtFolder.Text) = "" Then
     txtFolder.Text = "C:\"
  End If

  Me.MousePointer = vbHourglass
 
 'setting the list visibility to false
 'increases the load time
 lblTotal.Caption = ""
 lstLocations.Clear
 lstLocations.Visible = False
  
 'set up search params
  With FP
     .sFileRoot = txtFolder.Text       'start path
     .sFileNameExt = txtFilename.Text    'file type of interest
     .bRecurse = chkRecursive.Value = 1  '1 = recursive search
  End With
  
 'get start time, get files, and get finish time
  tstart = GetTickCount()
  Call SearchForFiles(FP)
  tend = GetTickCount()
  
  lstLocations.Visible = True
  
 'show the results
  lblTotal.Caption = Format$(FP.Count, "###,###,###,##0") & _
                       " found (" & _
                       FP.sFileNameExt & ")"
                  
  lblTime.Caption = FormatNumber((tend - tstart) / 1000, 2) & "  seconds"
                                   
  Me.MousePointer = vbNormal

End Sub


Private Sub GetFileInformation(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
  Dim sTmp As String
     
 'FP.sFileRoot contains the path to search.
 'FP.sFileNameExt 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 file specs,
       '*.* 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

          'this is where you add code to store
          'or display the returned file listing.
          '
          'if you want the file name only, save 'sTmp'.
          'if you want the full path, save 'sRoot & sTmp'

          'remove trailing nulls
           FP.Count = FP.Count + 1
           sTmp = TrimNull(WFD.cFileName)
          lstLocations.AddItem sRoot & sTmp

        End If
        Me.refresh: DoEvents
     Loop While FindNextFile(hFile, WFD)
     
     
    'close the handle
     hFile = FindClose(hFile)
  
  End If

End Sub

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
  Dim sTmp As String
     
  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) Then
           
          '..and the Recurse flag was specified
           If FP.bRecurse Then
           
             'and if the folder is not the default
             'self and parent folders (a . or ..)
              If Asc(WFD.cFileName) <> vbDot Then
              
                '..then the item is a real folder, which
                'may contain other sub folders, so assign
                'the new folder name to FP.sFileRoot and
                'recursively call this function again with
                'the amended information.

                'remove trailing nulls
                 FP.sFileRoot = sRoot & TrimNull(WFD.cFileName)
                 Call SearchForFiles(FP)
                 
              End If
              
           End If
           
        End If
        
    'continue looping until FindNextFile returns
    '0 (no more matches)
     Loop While FindNextFile(hFile, WFD)
     
    'close the find handle
     hFile = FindClose(hFile)
  
  End If
  
End Sub

Private Function QualifyPath(sPath As String) As String

 'assures that a passed path ends in a slash
  If Right$(sPath, 1) <> "\" Then
     QualifyPath = sPath & "\"
  Else
     QualifyPath = sPath
  End If
     
End Function


Private 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