Private nCount As Long
Private bCancel As Boolean
Dim sAllFiles() As String

Private Const MAXDWORD As Long = &HFFFFFFFF
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const SW_SHOWNORMAL As Long = 1

Private Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
Private Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &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 = 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:\winnt\
   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 Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function ShellExecute Lib "shell32" _
   Alias "ShellExecuteA" _
  (ByVal hwnd As Long, _
   ByVal lpOperation As String, _
   ByVal lpFile As String, _
   ByVal lpParameters As String, _
   ByVal lpDirectory As String, 
   ByVal nShowCmd As Long) As Long         



Private Sub Form_Load()

   With Combo1
      .AddItem "*.*"
      .AddItem "*.dll"
      .AddItem "*.exe"
      .AddItem "*.vbp"
      .AddItem "*.frm"
      .AddItem "*.bas"
      .ListIndex = 0
   End With
   
   With Combo2
       Call GetSystemDrives(Combo2)
      .ListIndex = 0
   End With
      
   With Combo3
      .AddItem "all fixed disks/partitions"
       Call GetSystemDrives(Combo3)
      .ListIndex = 0
   End With
   
   Command2.Enabled = False
   Command3.Enabled = False
   
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 = ""
   nCount = 0
   bCancel = False
   Command1.Enabled = False
   Command2.Enabled = True
   Command3.Enabled = False
   DoEvents
   
  'FP.sFileNameExt is the file type to list.
  'If FP.sFileRoot > Combo3's first item,
  'only the specified drive is searched.
   With FP
      .sFileNameExt = Combo1.Text
      .sFileRoot = Combo3.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 GetAllFilesSpecified(FP)

   If bCancel = False Then
  
     '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 if not cancelled
      Call SaveFile(Text1.Text)
      
      Command3.Enabled = True
      
   Else
   
      Text3.Text = Format$(nCount, "###,###,###,##0") & " .. cancelled"
   
   End If
   
  'free memory (unless you need this array later)
   Erase sAllFiles()
   
   Command1.Enabled = True
   Command2.Enabled = False
   
End Sub


Private Sub Command2_Click()

   bCancel = True
   
End Sub


Private Sub Command3_Click()

   Dim sTopic As String
   Dim sFile As String
   Dim sParams As Variant
   Dim sDirectory As Variant
    
  'open the file with the associated app
   sTopic = "Open"
   sFile = Text1.Text
   sParams = 0&   sDirectory = 0&               
   Call RunShellExecute(sTopic, sFile, sParams, sDirectory, SW_SHOWNORMAL)

End Sub


Private Sub Command4_Click()

   Dim tmp As String
   
   tmp = "File Type:      the file type to include in the search" & vbCrLf
   tmp = tmp & "Search:         the drive(s) to search" & vbCrLf
   tmp = tmp & "Output Drv:  target drive for the saved file" & vbCrLf
   tmp = tmp & "Output To:    output file name" & vbCrLf & vbCrLf
   tmp = tmp & "The output filename is automatically created based on the " & vbCrLf
   tmp = tmp & "above settings.  It can be manually overridden, however no " & vbCrLf
   tmp = tmp & "validity check is performed on the manually-entered path."
   
   MsgBox tmp, vbOKOnly Or vbInformation
   
End Sub


Private Sub Combo2_Click()

   Dim sDrv As String
   Dim sFile As String
   
   If (Combo2.ListIndex > -1) And (Len(Text1.Text) > 0) Then
   
      sDrv = LCase$(Combo2.List(Combo2.ListIndex))
      sFile = Mid$(Text1.Text, InStr(Text1.Text, "\"))
      
      Text1.Text = sDrv & sFile
   
   End If

End Sub


Private Sub Combo3_Click()

   Dim sDrv As String
   Dim sSearch As String
   
   sDrv = LCase$(Combo2.List(Combo2.ListIndex))
   
   If Combo3.ListIndex > -1 Then
   
      Select Case Combo3.ListIndex
         Case 0
            Text1.Text = sDrv & "\drive_all.txt"
            
         Case Else
            sSearch = LCase$(Combo3.List(Combo3.ListIndex))
            Text1.Text = sDrv & "\drive_" & Left$(sSearch, 1) & ".txt"
         
      End Select
   End If
   
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 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

           '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 GetAllFilesSpecified(FP As FILE_PARAMS)

   Dim drvCount As Long
   Dim sBuffer As String
   Dim currDrive As String
   
   If FP.sFileRoot = "all fixed disks/partitions" Then
   
     'all drives
   
     '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
               
               DoEvents
               If bCancel Then Exit Do
               
               Call SearchForFilesArray(FP)
               
              'Update the display count
               Text3.Text = Format$(nCount, sFileCount) & "files so far.."
               Text3.Refresh
               
            End If
         
         Loop
      
      End If
      
   Else
   
      'single drive
       Text2.Text = "Working ... searching drive " & FP.sFileRoot
       Text2.Refresh
       
       Call SearchForFilesArray(FP)
       
   End If

End Sub


PrivateFunction 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
   hFile = FreeFile
   
  'open and save to a normal file
   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


Private Sub RunShellExecute(sTopic As String, _
                            sFile As Variant, _
                            sParams As Variant, _
                            sDirectory As Variant, _
                            nShowCmd As Long)

   Dim hWndDesk As Long
   Dim success As Long
  
  'the desktop will be the
  'default for error messages
   hWndDesk = GetDesktopWindow()
  
  'execute the passed operation
   success = ShellExecute(hWndDesk, sTopic, sFile, sParams, sDirectory, nShowCmd)

  'have the "Open With.." dialog appear
  'when the ShellExecute API call fails
  If success < 32 Then
     Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " & sFile, vbNormalFocus)
  End If
   
End Sub


Private Sub GetSystemDrives(ctl As ComboBox)

   Dim drvCount As Long
   Dim sBuffer As String
   Dim currDrive As String
       
  'Retrieve the available drives on the system.
  'The string is padded with enough room to hold 
  'the drives, nulls and final terminating null.
   sBuffer = Space$(105)
   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
         currDrive = StripItem(sBuffer)

        'just search the local file system
         If GetDriveType(currDrive) = DRIVE_FIXED Then
         
            ctl.AddItem Left$(currDrive, 2)
            
         End If
      
      Loop
      
   End If

End Sub