Dim nCount As Long
Dim sAllFiles() As String

Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
Private Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN As Long = &H2
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const FILE_ATTRIBUTE_READONLY As Long = &H1
Private Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100
Private Const FILE_ATTRIBUTE_FLAGS As Long = FILE_ATTRIBUTE_ARCHIVE Or _
                                            FILE_ATTRIBUTE_HIDDEN Or _
                                            FILE_ATTRIBUTE_NORMAL Or _
                                            FILE_ATTRIBUTE_READONLY

Private Const DRIVE_UNKNOWN As Long = 0
Private Const DRIVE_NO_ROOT_DIR As Long = 1
Private Const DRIVE_REMOVABLE As Long = 2
Private Const DRIVE_FIXED As Long = 3
Private Const DRIVE_REMOTE As Long = 4
Private Const DRIVE_CDROM As Long = 5
Private Const DRIVE_RAMDISK As Long = 6

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

'the custom-made UDT for searching
Private Type FILE_PARAMS
   bRecurse As Boolean   'set True to perform a recursive search
   bList As Boolean      'set True to add results to listbox
   bFound As Boolean     'set only with SearchTreeForFile methods
   sFileRoot As String   'search starting point, i.e. c:\, c:\windows\
   sFileNameExt As String'filename/filespec to locate, i.e. *.dll, notepad.exe
   sResult As String     'path to file. Set only with SearchTreeForFile methods
   nFileCount As Long    'total file count matching filespec. Set in FindXXX only
   nFileSize As Double   'total file size matching filespec. Set in FindXXX only
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 GetLogicalDriveStrings Lib "kernel32" _
   Alias "GetLogicalDriveStringsA" _
  (ByVal nBufferLength As Long, 
   ByVal lpBuffer As String) As Long
      
Private Declare Function GetDriveType Lib "kernel32" _
   Alias "GetDriveTypeA" _
  (ByVal nDrive As String) As Long
  
  

Private Sub Form_Load()

   With Combo1
      .AddItem "*.*"
      .AddItem "*.dll"
      .AddItem "*.exe"
      .AddItem "*.vbp"
      .AddItem "*.frm"
      .AddItem "*.bas"
      .ListIndex = 0
   End With
   
End Sub


Private Sub Form_Unload(Cancel As Integer)

   Erase sAllFiles()
   
End Sub


Private Sub Command1_Click()

   Dim FP As FILE_PARAMS
   
  'set up the display
   Text2.Text = ""
   Text3.Text = ""
   Command1.Enabled = False
   
  'only parameter needed - can be
  'any filespec desired
   With FP
      .sFileNameExt = Combo1.Text
   End With
   
  'dim an array large enough to hold all
  'the returned values
   ReDim sAllFiles(1 To 1000000) As String
         
  'call the routines
   Call GetAllFiles(FP)

  'done. Show the results, and ..
   Text3.Text = Format$(nCount, "###,###,###,##0") & "files found"
   
  'strip off the unused allocated array members
   ReDim Preserve sAllFiles(1 To nCount)
   
  'and save the file
   Call SaveFile(Text1.Text)
   
  'free memory
   Erase sAllFiles()
   
   Command1.Enabled = True
   
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 (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 may use a filespec,
        '*.* 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

           'remove trailing nulls
            sTmp = TrimNull(WFD.cFileName)

           'increment count and add to the array
            nCount = nCount + 1
            sAllFiles(nCount) = sRoot & sTmp

         End If

      Loop While FindNextFile(hFile, WFD)

     'close the handle
      hFile = FindClose(hFile)

   End If

End Sub


Private Sub GetAllFiles(FP As FILE_PARAMS)

   Dim drvCount As Long
   Dim sBuffer As String
   Dim currDrive As String
       
  'retrieve the available drives on the system
   sBuffer = Space$(64)
   drvCount = GetLogicalDriveStrings(Len(sBuffer), sBuffer)
   
  'drvCount returns the size of the drive string
   If drvCount Then
   
     'strip off trailing nulls
      sBuffer = Left$(sBuffer, drvCount)
           
     'search each drive for the file
      Do Until sBuffer = ""

        'strip off one drive item from sBuffer
         FP.sFileRoot = StripItem(sBuffer)

        'just search the local file system
         If GetDriveType(FP.sFileRoot) = DRIVE_FIXED Then
         
           'this may take a while, so update the
           'display when the search path changes
            Text2.Text = "Working ... searching drive " & FP.sFileRoot
            Text2.Refresh
            
            Call SearchForFilesArray(FP)
            
           'Update the display count
            Text3.Text = Format$(nCount, "###,###,###,##0") & "files so far.."
            Text3.Refresh
            
         End If
      
      Loop
      
   End If

End Sub


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


Private Sub SearchForFilesArray(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
      
  'this routine is primarily interested in the
  'directories, so the file type must be *.*
   sRoot = QualifyPath(FP.sFileRoot)
   sPath = sRoot & "*.*"
   
  'obtain handle to the first match
   hFile = FindFirstFile(sPath, WFD)
   
  'if valid ...
   If hFile <> INVALID_HANDLE_VALUE Then
   
     'GetFileInformation function returns the number,
     'of files matching the filespec (FP.sFileNameExt)
     'in the passed folder.
      Call GetFileInformation(FP)

      Do
      
        'if the returned item is a folder...
         If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
            
           'remove trailing nulls
            sTmp = TrimNull(WFD.cFileName)
            
           'and if the folder is not the default
           'self and parent folders...
            If sTmp <> "." And sTmp <> ".." Then
            
              'get the file
               FP.sFileRoot = sRoot & sTmp
               
               
              'This next If..Then just prevents adding extra
              'lines and unneeded paths to the array when a
              'file search is performed for a specific file type
               If FP.sFileNameExt = "*.*" Then
               
                 'Depending on the purpose, you may want to
                 'exclude the next 4 optional lines.
                 'The first two lines adds a blank entry
                 'to the array as a separator between new
                 'directories in the output file. The last
                 'two add the directory name alone, before
                 'listing the files underneath. These four
                 'lines can be optionally commented out).
                 'Obviously, these extra entries will skew
                 'the actual file counts.
                  nCount = nCount + 1
                  sAllFiles(nCount) = ""
                  nCount = nCount + 1
                  sAllFiles(nCount) = FP.sFileRoot
               
               End If
               
              'call again
               Call SearchForFilesArray(FP)
            
            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


Function StripItem(startStrg As String) As String

  'Take a string separated by Chr(0)'s, and split off 1 item, and
  'shorten the string so that the next item is ready for removal.
   Dim pos As Integer

   pos = InStr(startStrg, Chr$(0))

   If pos Then
      StripItem = Mid$(startStrg, 1, pos - 1)
      startStrg = Mid$(startStrg, pos + 1, Len(startStrg))
   End If

End Function


Private Sub SaveFile(sOutputFile As String)

   Dim cnt As Long
   Dim hFile As Long
   
   Text2.Text = "Writing file ..."
   Text2.Refresh
   
  'obtain the next free file handle from the system
  'and open and save to a normal file - just takes a sec
   hFile = FreeFile
   Open sOutputFile For Output As #hFile
   
   For cnt = 1 To UBound(sAllFiles)
     Print #hFile, sAllFiles(cnt)
   Next
   
   Close #hFile
   
   Text2.Text = "Writing file ... Done!"
   
End Sub