Attribute VB_Name = "basdhFileFindModules"
Option Compare Database
Option Explicit

'Attribute VB_Name = "basSearch"

' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.

' Examples from Chapter 12

' Windows API search function
Private Declare Function SearchPath Lib "kernel32" _
  Alias "SearchPathA" (ByVal lpPath As String, _
 ByVal lpFileName As String, ByVal lpExtension As String, _
 ByVal nBufferLength As Long, ByVal lpBuffer As String, _
 ByVal lpFilePart As String) As Long
 
 ' Functions for searching for files in a given directory
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 FindClose Lib "kernel32" _
 (ByVal hFindFile As Long) As Long
 ' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.

' Examples from Chapter 12

' Max size for a file path
Public Const MAX_PATH = 260

Type FILETIME
  lngLowDateTime As Long
  lngHighDateTime As Long
End Type

Type WIN32_FIND_DATA
    lngFileAttributes As Long           ' File attributes
    ftCreationTime As FILETIME          ' Creation time
    ftLastAccessTime As FILETIME        ' Last access time
    ftLastWriteTime As FILETIME         ' Last modified time
    lngFileSizeHigh As Long             ' Size (high word)
    lngFileSizeLow As Long              ' Size (low word)
    lngReserved0 As Long                ' reserved
    lngReserved1 As Long                ' reserved
    strFileName As String * MAX_PATH    ' File name
    strAlternate As String * 14         ' 8.3 name
End Type

' GetDriveType return values
Private Const DRIVE_UNKNOWN = 0
Private Const DRIVE_NOROOT = 1
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6

Private Declare Function GetDriveType Lib "kernel32" _
    Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
    Alias "GetLogicalDriveStringsA" _
    (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function fWrite Lib "kernel32" Alias "_lwrite" (ByVal hFile%, _
  ByVal lpBuff&, ByVal nBuff%) As Long
Private Declare Function fRead Lib "kernel32" Alias "_lread" (ByVal hFile%, _
  ByVal lpBuff&, ByVal nBuff%) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags%, _
  ByVal dwBytes&) As Integer
Private Declare Function GlobalFree Lib "kernel32" Alias "GLobalFree" (ByVal hMem%) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem%) As Long
Private Declare Function GlobalUnlock Lib "kernel32" Alias "GLobalUnlock" (ByVal hMem%) As Long
Const dhcErrKeyInUse = 457




 
 
Function zdhSearchPath(strFile As String, _
 Optional strPath As String = vbNullString) As String

    ' Wrapper for Windows API SearchPath function. Accepts a
    ' path string (like the DOS PATH environmental variable) and
    ' looks for a file in those directories

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   strFile
    '       File to search for.
    '   strPath (Optional, default = vbNullString)
    '       Path string (e.g. "C:\;C:\DOS;C:\WINDOWS") or
    '       an empty string to use the default search directories.
    ' Out:
    '   Return Value:
    '       Full path of file, if found, or empty string.
    ' Note:
    '       For files that exist in more than one specified
    '       directory, the first matching one is returned
    '       (search order is left to right in the list).
    ' Example:
    '   Debug.Print dhSearch("COMMAND.COM", "C:\;C:\DOS;C:\WINDOWS")

    Dim strBuffer As String
    Dim lngBytes As Long
    Dim strFilePart As String
    
    ' Create a buffer
    strBuffer = Space(MAX_PATH)
    
    ' Call search path
    lngBytes = SearchPath(strPath, strFile, vbNullString, _
     Len(strBuffer), strBuffer, strFilePart)
     
    ' If successful, parse out the file name
    If lngBytes > 0 Then
        zdhSearchPath = Left(strBuffer, lngBytes)
    End If
End Function

Function dhFindAllFiles(strSpec As String, _
 ByVal strPath As String, colFound As Collection, _
 Optional lngAttr As Long = -1, _
 Optional fRecursive As Boolean = True, _
 Optional objCallback As Object, _
 Optional blnSorted As Boolean = False) As Long

' Note change to routine in comments.

    ' Finds file(s) based on a specification in a directory
    ' plus (optionally) all subdirectories.

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   strSpec
    '       File specification to search for.
    '   strPath
    '       Starting path.
    '   colFound
    '       Pointer to VBA Collection object.
    '   lngAttr (Optional, default = -1)
    '       File attributes to search for (-1 for all files).
    '   fRecursive (Optional, default = True)
    '       If True, a recursive search of all subdirectories is made.
    '   objCallback (Optional)
    '       Optional pointer to a callback object (see chapter
    '       text for details).
    ' Out:
    '   colFound
    '       Contains one element for each matching filename,
    '       including complete path).
    '   Return Value:
    '       Number of files found.
    ' Example:
    '   See dhPrintFoundFiles for example

    Dim strFile As String
    Dim colSubDir As New Collection
    Dim varDir As Variant
    
    ' Make sure strPath ends in a backslash
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
    
    ' If the callback object was supplied
    ' call its Searching method
    If Not objCallback Is Nothing Then
        objCallback.Searching strPath
    End If
        
    ' Find all files in the directory--if no
    ' attributes were specified use a non-exclusive
    ' search for all files, otherwise use a
    ' restrictive search for the attributes
    If lngAttr = -1 Then
        strFile = dhDir(strPath & strSpec, , False)
    Else
        strFile = dhDir(strPath & strSpec, lngAttr)
    End If
     
    Do Until strFile = ""
    
        ' Add file to collection if attributes match
        ' (special case directories "." and ".."
'                    If ((GetAttr(strPath & strFile) And lngAttr) > 0) _
'                    And (strFile <> ".") And (strFile <> "..") Then
         If (strFile <> ".") And (strFile <> "..") Then
            If blnSorted = True Then
              Call dhAddToSortedCollection(colFound, strPath & strFile)
            Else
              colFound.Add strPath & strFile
            End If
        End If
        
        ' If the callback object was supplied
        ' call its Found method
        If Not objCallback Is Nothing Then
           ' Commented TMD 22/08/02 objCallback.Found strPath, strFile
        End If
        
        ' Get the next file
        strFile = dhDir
    Loop
    
    ' If the recursive flag is set build a list
    ' of all the subdirectories
    If fRecursive Then
        
        strFile = dhDir(strPath, vbDirectory)
        Do Until strFile = ""
            ' Ignore "." and ".."
            If strFile <> "." And strFile <> ".." Then
            
                ' Add each to the directory collection
                colSubDir.Add strPath & strFile
            End If
            strFile = dhDir
        Loop
        
        ' Now recurse through each sub directory
        For Each varDir In colSubDir
            dhFindAllFiles strSpec, varDir, colFound, _
             lngAttr, fRecursive, objCallback
        Next
    End If
    
    ' Return the number of found files
    dhFindAllFiles = colFound.Count
End Function

Sub dhPrintFoundFiles(strSpec As String, strPath As String)

    ' Sample procedure demonstrating recursive file search function.

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   strSpec
    '       File specification.
    '   strPath
    '       Starting directory.
    ' Out:
    '   Return Value:
    '       n/a
    ' Example:
    '   Call dhPrintFoundFiles("C:\", "*.BAK")
 
    Dim colFound As New Collection
    Dim lngFound As Long
    Dim varFound As Variant
    
    ' Test the file find logic
'    Debug.Print "Starting search..."
    
    ' Call dhFindAllFiles
    lngFound = dhFindAllFiles(strSpec, strPath, colFound, fRecursive:=False)
    
    ' Print the results
'    Debug.Print "Done. Found: " & lngFound
      
    ' With the collection of filenames
    ' you can do something with them
'    Debug.Print
'    Debug.Print "What we found:"
'    Debug.Print "=============="

'    For Each varFound In colFound
'        Debug.Print varFound
'    Next
End Sub

Sub dhPrintFoundFilesWithFeedback(strSpec As String, _
 strPath As String)

    ' Sample procedure demonstrating recursive file search function.
    ' (Also uses a sample callback object)

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   strSpec
    '       File specification.
    '   strPath
    '       Starting directory.
    ' Out:
    '   Return Value:
    '       n/a
    ' Example:
    '   Call dhPrintFoundFilesWithFeedback("C:\", "*.BAK")
 
    Dim colFound As New Collection
    Dim lngFound As Long
    Dim objCallback As New FileFindCallback
    
    ' Test the file find logic
    Debug.Print "Starting search..."
    
    ' Call dhFindAllFiles, passing a callback
    ' object--the callback object will print
    ' the filenames to the Immediate window
    ' as they are found
    lngFound = dhFindAllFiles(strSpec, strPath, _
     colFound, , False, objCallback)
    
    ' Print the results
    'Added for Test TMD
    Dim lngCount As Long
    For lngCount = 1 To colFound.Count
      Debug.Print colFound(lngCount)
    Next
    
    Debug.Print "Done. Found: " & lngFound
End Sub




Sub dhFindFiles(strPath As String)

    ' Sample procedure demonstrating Windows API Find... functions.

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   strPath
    '       Path to a directory containing files, plus a
    '       file specification.
    ' Out:
    '   Return Value:
    '       n/a
    ' Note:
    '   Prints the file name, size, and attributes to the Immediate window
    ' Example:
    '   Call dhFindFiles("C:\*.*")

    Dim fd As WIN32_FIND_DATA
    Dim hFind As Long
    
    ' Find the first file
    hFind = FindFirstFile(strPath, fd)
    
    ' If successful...
    If hFind > 0 Then
        Do
            ' Print file information
            With fd
                Debug.Print dhTrimNull(.strFileName), _
                 .lngFileSizeLow & " bytes", _
                 dhBuildAttrString(.lngFileAttributes)
            End With
            
        ' Find the next file and continue as long
        ' as they are files to be found
        Loop While CBool(FindNextFile(hFind, fd))
        
        ' Terminate the find operation
        Call FindClose(hFind)
    End If
End Sub

Function dhDir(Optional ByVal strPath As String = "", _
 Optional lngAttributes As Long = vbNormal, _
 Optional fExclusive As Boolean = True) As String

    ' Replacement for the VBA Dir function which lets you
    ' specify file attributes for a restrictive search.

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   strPath (Optional, default = "")
    '       Path and/or file specification to search.
    '   lngAttributes (Optional, default = vbNormal)
    '       File attributes.
    '   fExclusive (Optional, default = True)
    '       If True, only those files with the matching
    '       file attributes are returned.
    ' Out:
    '   Return Value:
    '       If called with a file specification, the first
    '       matching filename is returned. If called without
    '       a file specification, the next matching filename
    '       is returned. When no additional matching filenames
    '       are found, an empty string is returned.
    ' Example:
    '   Dim strDir As String
    '
    '   strDir = dhDir("C:\", vbDirectory)
    '   Do Until strDir = ""
    '       Debug.Print strDir
    '       strDir = dhDir()
    '   Loop
      
    Dim fd As WIN32_FIND_DATA
    Static hFind As Long
    Static lngAttr As Long
    Static fEx As Boolean
    
    ' If no path was passed, try to find the next file
    If strPath = "" Then
        If hFind > 0 Then
            If CBool(FindNextFile(hFind, fd)) Then
                dhDir = dhFindByAttr(hFind, fd, lngAttr, fEx)
            End If
        End If
        
    ' Otherwise, start a new search
    Else
        ' Close the last find if there was one
        If hFind > 0 Then
            Call FindClose(hFind)
        End If
        
        ' Store the attributes and exclusive settings
        lngAttr = lngAttributes
        fEx = fExclusive
        
        ' If the path ends in a backslash, assume
        ' all files and append "*.*"
        If Right(strPath, 1) = "\" Then
            strPath = strPath & "*.*"
        End If
        
        ' Find the first file
        hFind = FindFirstFile(strPath, fd)
        If hFind > 0 Then
            dhDir = dhFindByAttr(hFind, fd, lngAttr, fEx)
        End If
    End If
End Function

Function dhFindByAttr(hFind As Long, _
 fd As WIN32_FIND_DATA, lngAttr As Long, _
 fExclusive As Boolean) As String

    ' Determines if a file matches the specified attrbites.

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   hFind
    '       Windows API Find handle.
    '   fd
    '       Pointer to populated WIN32_FIND_DATA structure.
    '   lngAttr
    '       Attributes to test for.
    '   fExclusive
    '       If True, only those files with the matching
    '       file attributes are returned.
    ' Out:
    '   Return Value:
    '       Next matching filename.
    ' Example:
    '   See dhDir for usage
 
    Dim fOk As Boolean
 
    ' Continue looking for files until one
    ' matches the given attributes exactly
    ' (if fExclusive is True) or just contains
    ' them (if fExclusive is False)
    Do
        If fExclusive Then
            fOk = fd.lngFileAttributes = lngAttr
        Else
            fOk = (fd.lngFileAttributes And lngAttr) = lngAttr
        End If
            
        If fOk Then
            dhFindByAttr = dhTrimNull(fd.strFileName)
            Exit Do
        End If
    Loop While FindNextFile(hFind, fd)
End Function


Function dhTrimNull(ByVal strValue As String) As String
    ' Find the first vbNullChar in a string, and return
    ' everything prior to that character. Extremely
    ' useful when combined with the Windows API function calls.
    
    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.
    
    ' In:
    '   strValue:
    '       Input text, possibly containing a null character
    '       (chr$(0), or vbNullChar)
    ' Out:
    '   Return Value:
    '       strValue trimmed on the right, at the location
    '       of the null character, if there was one.
    
    Dim intPos As Integer
    
    intPos = InStr(strValue, vbNullChar)
    Select Case intPos
        Case 0
            ' Not found at all, so just
            ' return the original value.
            dhTrimNull = strValue
        Case 1
            ' Found at the first position, so return
            ' an empty string.
            dhTrimNull = ""
        Case Is > 1
            ' Found in the string, so return the portion
            ' up to the null character.
            dhTrimNull = Left$(strValue, intPos - 1)
    End Select
End Function
Function dhBuildAttrString(lngAttr As Long) As String

    ' Builds up a string representing the attributes of
    ' a given file..

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   lngAttr
    '       File attributes.
    ' Out:
    '   Return Value:
    '       String representing attributes. For example,
    '       for a read-only, hidden directory, the result
    '       would be "RH  D"
    ' Example:
    '   Debug.Print dhBuildAttrString(lngAttr)

    Dim strAttr As String
    
    ' Build up an attribute string
    dhBuildAttr strAttr, lngAttr, vbReadOnly, "R"
    dhBuildAttr strAttr, lngAttr, vbHidden, "H"
    dhBuildAttr strAttr, lngAttr, vbSystem, "S"
    dhBuildAttr strAttr, lngAttr, vbArchive, "A"
    dhBuildAttr strAttr, lngAttr, vbDirectory, "D"
    
    ' Return attribute string
    dhBuildAttrString = strAttr
End Function
Sub dhBuildAttr(strAttr As String, lngAttr As Long, _
 lngMask As Long, strSymbol As String)

    ' Used by the dhBuildAttrFunction to test for one
    ' attribute.

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   strAttr
    '       Current attribute string.
    '   lngAttr
    '       Bitmask of file attributes.
    '   lngMask
    '       Attribute to test for (e.g. vbReadOnly).
    '   strSymbol
    '       Symbol to use for string (e.g. "R").
    ' Out:
    '   strAttr
    '       Attribute string with new symbol appended.
    '   Return Value:
    '       n/a
    ' Example:
    '   Call dhBuildAttr(strAttr, lngAttr, vbHidden, "H")

    ' Compare the passed attributes with the
    ' mask--if it matches append the passed
    ' symbol to the string
    If (lngAttr And lngMask) = lngMask Then
        strAttr = strAttr & strSymbol
    Else
        strAttr = strAttr & " "
    End If
End Sub


Sub dhPrintDriveTypes()

    ' Sample procedure demonstrating GetDriveType API function.

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   n/a
    ' Out:
    '   n/a
    ' Example:
    '   Call dhPrintDriveTypes

    Dim colDrives As New Collection
    Dim varDrive As Variant
    Dim lngType As Long
    
    ' Get drive letters
    If dhGetDrivesByString(colDrives) > 0 Then
        For Each varDrive In colDrives
            ' Print drive letter
            Debug.Print varDrive,
            
            ' Print drive type
            lngType = GetDriveType(CStr(varDrive))
            Select Case lngType
                Case DRIVE_UNKNOWN
                    Debug.Print "Unknown"
                Case DRIVE_NOROOT
                    Debug.Print "Unknown"
                Case DRIVE_REMOVABLE
                    Debug.Print "Removable Media"
                Case DRIVE_FIXED
                    Debug.Print "Fixed Disk"
                Case DRIVE_REMOTE
                    Debug.Print "Network Drive"
                Case DRIVE_CDROM
                    Debug.Print "CD-ROM"
                Case DRIVE_RAMDISK
                    Debug.Print "RAM Disk"
            End Select
        Next
    End If
End Sub
Function dhGetDrivesByString(colDrives As Collection) _
 As Integer

    ' Retrieves a collection of drives as string ("a:\", "b:\", etc.).

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.

    ' In:
    '   colDrives
    '       Pointer to VBA collection object.
    ' Out:
    '   colDrives
    '       Contains one entry for each installed drive.
    '   Return Value:
    '       Number of drives.
    ' Example:
    '   Dim colDrives As New Collection
    '   Dim varDrive As Variant
    '
    '   If dhGetDrivesByString(colDrives) > 0 Then
    '       For Each varDrive In colDrives
    '           Debug.Print varDrive
    '       Next
    '   End If

 
    Dim strBuffer As String
    Dim lngBytes As Long
    Dim intPos As Integer
    Dim intPos2 As Integer
    Dim strDrive As String
    
    ' Reset the collection
    Set colDrives = New Collection
    
    ' Set up a buffer
    strBuffer = Space(255)
    
    ' Get the logical drive string
    lngBytes = GetLogicalDriveStrings( _
     Len(strBuffer), strBuffer)
    
    ' Parse the drive string by looking
    ' for the null delimiter
    intPos2 = 1
    intPos = InStr(intPos2, strBuffer, vbNullChar)
    Do Until intPos = 0 Or intPos > lngBytes
    
        ' Parse out the drive letter
        strDrive = Mid(strBuffer, intPos2, intPos - intPos2)
            
        ' Add it to the collection
        colDrives.Add strDrive, strDrive
        
        ' Find the next drive letter
        intPos2 = intPos + 1
        intPos = InStr(intPos2, strBuffer, Chr(0))
    Loop
    
    ' Return the number of drives found
    dhGetDrivesByString = colDrives.Count
    
End Function




' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.

' Maintain a sorted array by performing an insertion
' into the correct location in the collection.

Function dhAddToSortedCollection(col As Collection, varNewItem As Variant, _
 Optional strKey As String = "") As Boolean

    ' Add a value (and its associated key, if requested)
    ' to a collection.
    ' This is effectively performing an insertion sort, which
    ' isn't particularly effective. In general, you're going to
    ' look at n/2 elements to insert each element, so it's basically
    ' linear in speed.  Not good.  But it's certainly the simplest
    ' way to keep a collection sorted.
    
    ' FWIW, for simple items, it's faster to use an array,
    ' even using ReDim Preserve, and sort the array once
    ' you're done adding items. No kidding!
    
    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.
    
    ' In:
    '   col:
    '       Collection to which to add the new item.
    '   varNewItem:
    '       New value to be added to the collection. This will
    '       need to be a simple value.
    '   strKey:
    '       (Optional, default = "") Unique string identifier for
    '       this item. You'll need to specify a unique value here,
    '       or just leave it off.
    ' Out:
    '   Item is added to the collection, at the appropriate
    '   location.
    '   Return Value:
    '       True if successful, False otherwise.

    On Error GoTo HandleErrors
    
    Dim intI As Integer
    Dim fAdded As Boolean
    Dim fUseKey As Boolean
    
    fUseKey = (Len(strKey) > 0)
    
    ' On the first time through here, this loop
    ' will just do nothing at all.
    For intI = 1 To col.Count
        If varNewItem < col.Item(intI) Then
            If fUseKey Then
                col.Add varNewItem, strKey, intI
            Else
                col.Add varNewItem, , intI
            End If
            fAdded = True
            Exit For
        End If
    Next intI
    ' If the item hasn't been added, either because
    ' it goes past the end of the current list of items,
    ' or because there aren't currently any items to loop
    ' through, just add the item at the end of the
    ' collection.
    If Not fAdded Then
        If fUseKey Then
            col.Add varNewItem, strKey
        Else
            col.Add varNewItem
        End If
    End If
    dhAddToSortedCollection = True
    
ExitHere:
    Exit Function
    
HandleErrors:
    dhAddToSortedCollection = False
    Select Case Err.Number
        Case dhcErrKeyInUse
            ' This is the only likely error.
            
        Case Else
            ' Do nothing. Just bubble the error
            ' back up to the caller.
    End Select
    Resume ExitHere
End Function

Public Sub test()
' TMD Added
dhPrintFoundFilesWithFeedback strSpec:="Data*.accdb", strPath:="C:\Users\Peter\Documents\"
End Sub




