VBA利用递归与WinAPI查找特定字符串

下面的程序，分别利用函数还有API来递归查找特定字符 ，并且将查找到的行数输出到Excel中。

总体来说，利用API速度较快。

 

 Option Explicit

'API constants

Public Const MAX_PATH = 260

Public Const INVALID_HANDLE_VALUE = -1

Public Const FILE_ATTRIBUTE_DIRECTORY = &H10

'API types

Public Type FILETIME

    dwLowDateTime As Long

    dwHighDateTime As Long

End Type

Public 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

'API function calls

Public Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Public Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Public Declare Function FindClose Lib "kernel32.dll" (ByVal hFindFile As Long) As Long

Dim CurrentLine As Integer

Public Sub Search()

    CurrentLine = 1

    

    Dim intRow As Integer

    Dim strJobName As String

    Dim Dirs() As String

    Dim strFolder As String

    

    strFolder = "C:/Densan/Reams/AQ"

    

    intRow = 1

    strJobName = ActiveWorkbook.Sheets(2).Cells(intRow, 1)

    ActiveWorkbook.Sheets(3).Cells(1, 1) = Time()

    While strJobName <> ""

        

        'Use the Dir to recursion the files(include sub directorys)

        'rst = ListDirs(strFolder, Dirs(), True, strJobName, 0)

        

        'Use the WIN API to recursion the files(include sub directorys)

        DirSpace strFolder, strJobName

        

        intRow = intRow + 1

        strJobName = ActiveWorkbook.Sheets(2).Cells(intRow, 1)

        CurrentLine = CurrentLine + 1

    Wend

    

    ActiveWorkbook.Sheets(3).Cells(2, 1) = Time()

    

    MsgBox "OK"

    

End Sub

'Use the Dir to recursion the files(include sub directorys)

Private Function ListDirs(ByVal path As String, _

                          ByRef Dirs() As String, _

                          ByVal Recursive As Boolean, _

                          ByVal strFind As String, _

                          Optional Dircount As Long = 0) As Boolean

          Dim Dirname     As String

          Dim Dirstart     As Long

          Dim a     As Long

            

          '   On   Error   GoTo   ErrorHandler

            

          Dirstart = Dircount + 1

          If (Dircount = 0) Then

                  ReDim Dirs(0)

                  path = IIf(Right$(path, 1) = "/", path, path + "/")

          End If

            

          If InStr(1, path, "bin") > 0 Or InStr(1, path, "obj") > 0 Or InStr(1, path, "Batch") > 0 Then

          Else

              filesSerach path, strFind

          End If

          

          Dirname = Dir$(path + "*.*", vbDirectory)

          Do While (Dirname <> "")

            If (Dirname <> ".") And (Dirname <> "..") And ((GetAttr(path + Dirname) And vbDirectory) = vbDirectory) Then

                Dircount = Dircount + 1

                ReDim Preserve Dirs(Dircount)

                Dirs(Dircount) = path & Dirname & "/"

                filesSerach Dirs(Dircount), strFind

                

            End If

            Dirname = Dir

          Loop

            

          If Recursive Then

                  For a = Dirstart To Dircount

                      If InStr(1, Dirs(a), "bin") > 0 Or InStr(1, Dirs(a), "obj") > 0 Or InStr(1, Dirs(a), "Batch") > 0 Then

                      Else

                          If Not ListDirs(Dirs(a), Dirs, Recursive, strFind, Dircount) Then

                                  ListDirs = False

                                  Exit Function

                          End If

                      End If

                  Next

          End If

            

          ListDirs = True

          Exit Function

            

ErrorHandler:

          'Any   error   message(s)   can   be   placed   here

          ListDirs = False

    

End Function

'Use the FileSystemObject to get the files under the given dierctory

Private Sub filesSerach(ByVal directory As String, ByVal strFind)

    Dim fs

    Dim folder

    Dim files

    Dim f1

    Dim lineNo As Integer

    Dim strLine As String

    

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set folder = fs.GetFolder(directory)

    Set files = folder.files

    

    For Each f1 In files

        fSerach f1, strFind

    Next

End Sub

'Search the given content in the file

Private Sub fSerach(ByVal f1 As String, ByVal strFind)

    Dim lineNo As Integer

    Dim strLine As String

    lineNo = 0

    

    If (LCase(Right(f1, 2)) = "vb") Or (LCase(Right(f1, 3)) = "xml") Then

    

        Open f1 For Input As #1

        Do Until EOF(1)

            Line Input #1, strLine

            If InStr(1, strLine, strFind) > 0 Then

                OutPutResult f1, lineNo, strLine

            End If

            lineNo = lineNo + 1

        Loop

        Close #1

        

    End If

        

End Sub

'Output the Result to excel sheet

Private Sub OutPutResult(ByVal filePath As String, ByVal lineNo As Integer, ByVal strLine As String)

    CurrentLine = CurrentLine + 1

    ActiveWorkbook.Sheets(1).Cells(CurrentLine, 1) = filePath

    ActiveWorkbook.Sheets(1).Cells(CurrentLine, 2) = lineNo

    ActiveWorkbook.Sheets(1).Cells(CurrentLine, 3) = strLine

End Sub

'Truncate a string returned by API calls to the first null char Chr(0)

Private Function APItoString(s As String) As String

    Dim x As Integer

    x = InStr(s, Chr(0))

    If x <> 0 Then

        APItoString = Left(s, x - 1)

    Else

        APItoString = s

    End If

End Function

'Use the API to Recursion the files

Public Sub DirSpace(sPath As String, ByVal strFind As String)

    Dim f As WIN32_FIND_DATA

    Dim hFile As Long

    Dim hSize As Long

    Dim fName As String

    'Add the slash to the search path

    If Right(sPath, 1) <> "/" Then sPath = sPath & "/"

    'start a file enum in the specified path

    hFile = FindFirstFile(sPath & "*.*", f)

    If hFile = INVALID_HANDLE_VALUE Then Exit Sub

    If (f.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = 0 Then

        'Count file size

        fSerach sPath & APItoString(f.cFileName), strFind

    ElseIf Left(f.cFileName, 1) <> "." Then

        'call the DirSpace with subdirectory

        DirSpace sPath & APItoString(f.cFileName), strFind

    End If

    'Enumerate all the files

    Do While FindNextFile(hFile, f)

        If (f.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = 0 Then

            'Search and Ouput the result

            fSerach sPath & APItoString(f.cFileName), strFind

        ElseIf Left(f.cFileName, 1) <> "." Then

            'call the DirSpace with subdirectory

            fName = APItoString(f.cFileName)

            If InStr(1, fName, "bin") > 0 Or InStr(1, fName, "obj") > 0 Or InStr(1, fName, "Batch") > 0 Then

            Else

                DirSpace sPath & fName, strFind

            End If

        End If

    Loop

    'Close the file search

    FindClose (hFile)

End Sub