vbAccelerator - Contents of code file: cFindInFiles.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cFindInFiles"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

' ==============================================================
' FileName:    cFindInFiles.cls
' Author:      SP McMahon
' Date:        14 January 2003
'
' Simple demo for mStart.bas.  See comments there
' for more information.  Attempts to find matches
' for the specified strings in a series of files
'
' ==============================================================

Implements Runnable

Private Declare Sub SleepAPI Lib "kernel32" Alias "Sleep" ( _
    ByVal dwMilliseconds As Long)
    
Public Event Complete()
Public Event Cancelled()
Public Event Status(ByVal sMsg As String, ByRef bCancel As Boolean)
Public Event Found(ByVal sFile As String, ByVal iPos As Long, ByRef bCancel As
 Boolean)

Private m_bRunning As Boolean
Private m_sDir As String
Private m_sFileSpec As String
Private m_bStopAtFirstMatch As Boolean
Private m_bRecurse As Boolean
Private m_sFindWhat As String
Private m_eCompare As VbCompareMethod

Public Property Get StartDirectory() As String
   StartDirectory = m_sDir
End Property
Public Property Let StartDirectory(ByVal value As String)
   m_sDir = value
End Property
Public Property Get FileSpec() As String
   FileSpec = m_sFileSpec
End Property
Public Property Let FileSpec(ByVal value As String)
   m_sFileSpec = value
End Property
Public Property Get FindWhat() As String
   FindWhat = m_sFindWhat
End Property
Public Property Let FindWhat(ByVal value As String)
   m_sFindWhat = value
End Property
Public Property Get FindAllMatchesInFile() As Boolean
   FindAllMatchesInFile = Not (m_bStopAtFirstMatch)
End Property
Public Property Let StopAtFirstMatch(ByVal value As Boolean)
   m_bStopAtFirstMatch = Not (value)
End Property
Public Property Get Recurse() As Boolean
   Recurse = m_bRecurse
End Property
Public Property Let Recurse(ByVal value As Boolean)
   m_bRecurse = value
End Property
Public Property Get MatchCase() As Boolean
   MatchCase = (m_eCompare = vbBinaryCompare)
End Property
Public Property Let MatchCase(ByVal value As Boolean)
   If value Then
      m_eCompare = vbBinaryCompare
   Else
      m_eCompare = vbTextCompare
   End If
End Property

Public Sub Start(Optional ByVal bAsync = True)
   
   If Not m_bRunning Then
      m_bRunning = True
      ' Call the mStart module.  This uses a timer to
      ' fire the Runnable_Start() implementation,
      ' which ensures we yield control back to the
      ' caller before the processing starts.  This
      ' ensures that the processing runs asynchronously
      ' to the client.  Easy!!!
      If (bAsync) Then
         mStart.Start Me
      Else
         Runnable_Start
      End If
   Else
      ' Just checking....
      Err.Raise 32540, App.EXEName & ".cAsync", "Already running."
   End If
   
End Sub

Private Sub Runnable_Start()
Dim i As Long
Dim bCancel As Boolean
   
   processFiles m_sDir, bCancel
   
   If (bCancel) Then
      RaiseEvent Cancelled
   Else
      RaiseEvent Complete
   End If
   
   ' All done:
   m_bRunning = False

End Sub
Private Function NormalizePath( _
      ByVal sPath As String _
   ) As String
   If (Right$(sPath, 1) <> "\") Then
      NormalizePath = sPath & "\"
   Else
      NormalizePath = sPath
   End If
End Function
Private Function processFiles( _
      ByVal sStartDir As String, _
      ByRef bCancel As Boolean _
   )
Dim sDirs() As String
Dim iCount As Long
Dim sFiles() As String
Dim sItem As String
Dim i As Long

   If Not bCancel Then
      
      ' If recursing, then check subdirs:
      If (m_bRecurse) Then
         sItem = Dir(NormalizePath(sStartDir) & "*.*", vbDirectory)
         Do While Len(sItem) > 0
            If (sItem <> ".") And (sItem <> "..") Then
               If (GetAttr(NormalizePath(sStartDir) & sItem) And vbDirectory) =
                vbDirectory Then
                  iCount = iCount + 1
                  ReDim Preserve sDirs(1 To iCount) As String
                  sDirs(iCount) = sItem
               End If
            End If
            sItem = Dir
         Loop
         For i = 1 To iCount
            processFiles NormalizePath(sStartDir) & sDirs(i), bCancel
         Next i
      End If
      
      ' Process the files:
      If Not bCancel Then
         sItem = Dir(NormalizePath(sStartDir) & m_sFileSpec, vbNormal)
         Do While (Len(sItem) > 0) And Not (bCancel)
            RaiseEvent Status("Checking: " & sItem, bCancel)
            findInFile NormalizePath(sStartDir) & sItem, bCancel
            sItem = Dir
         Loop
      End If
      
   End If
   
End Function

Private Function findInFile( _
      ByVal sFile As String, _
      ByRef bCancel As Boolean _
   )
Dim iFile As Integer
Dim iPos As Long
Dim iChunkSize As Long
Dim bComplete As Boolean
Dim sBuf As String

On Error GoTo ErrorHandler
   iChunkSize = 4096
   sBuf = Space$(iChunkSize)
   Debug.Print sFile

   iFile = FreeFile
   Open sFile For Binary Access Read Lock Write As #iFile
   Do While Not (bComplete) And Not (bCancel)
      If (iPos + iChunkSize >= LOF(iFile)) Then
         bComplete = True
         sBuf = Space$(LOF(iFile) - iPos)
      End If
      Get #iFile, , sBuf
      If (performFind(sFile, sBuf, iPos, bCancel) And m_bStopAtFirstMatch) Then
         bComplete = True
      End If
      If Not bComplete Then
         iPos = iPos + iChunkSize - Len(m_sFindWhat)
         Seek #iFile, iPos
      End If
   Loop

ErrorHandler:
   Close #iFile
   iFile = 0
   Exit Function
   
End Function
Private Function performFind( _
      ByVal sFile As String, _
      ByRef sBuf As String, _
      ByVal lOffset As Long, _
      ByRef bCancel As Boolean _
   ) As Boolean
Dim iPos As Long
Dim iLastPos As Long
Dim bComplete As Boolean
   iLastPos = 1
   Do
      iPos = InStr(iLastPos, sBuf, m_sFindWhat, m_eCompare)
      If (iPos > 0) Then
         iLastPos = iPos + Len(m_sFindWhat)
         RaiseEvent Found(sFile, lOffset + iPos, bCancel)
         performFind = True
         If (m_bStopAtFirstMatch) Then
            bComplete = True
         End If
      Else
         bComplete = True
      End If
   Loop While (Not bComplete And Not bCancel)
   
End Function