下面的程序，分别利用函数还有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
![在DOS下运行不了ipconfig命令[图]](data:image/gif;base64,R0lGODlhAQABAIAAAP///wAAACwAAAAAAQABAAACAkQBADs=)