Question

任何人都可以帮我一个vba代码，它会在共享驱动器的所有文件夹和子文件夹中的文本文件中搜索用户输入关键字。并且，如果在文本文件中找到关键字，则应返回包含文本文件的文件夹名称和路径。

我有一个Windows窗体，用户可以输入关键字，当用户点击搜索按钮时，它必须执行上述功能。

例如：如果用户搜索“Business”这样的关键字，则应该在共享驱动器的所有文件夹和子文件夹中的所有文本文件中查找“Business”。如果找到它，它应该返回文件夹名称及其包含文件的路径。输出示例

文件夹名称：ABC 文件夹路径：C：\ office \ ABC

任何人都可以帮我解决这些问题提前感谢你。

这是我的代码

Public Sub FindFiles（）

'添加了对“Microsoft Shell控件和自动化”的引用

Dim shl As Shell32.Shell

Dim fol As Shell32.Folder

Dim row As Long

设置shl = New Shell32.Shell

设置fol = shl.Namespace（“C：\ Users \”）

row = 1

ProcessFolderRecursively，fol，row

End Sub

Private Sub ProcessFolderRecursively（作为Shell32.Folder，ByRef行为长）

Dim item As Shell32.FolderItem

Dim fol2 As Shell32.Folder

如果没有，那么

enter code here

结束如果

End Sub

Answer 1

我相信这个答案会帮助你回答你的问题。

Using a wildcard to open an excel workbook

在VBA中，您不能使用*等通配符来打开文件。如果文件名和位置没有改变，那么你需要编译所有文件名的列表。

然后，您可以获取列表，打开列表中的每个文件，并使用find（）函数扫描文本doc以搜索关键字。如果找到，则返回文件名。

你面临的问题是编译文件位置来制作列表，我没有答案。其余的很容易。

Answer 2

以下代码可以帮助您

Option Explicit
Public Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)

Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Function

Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

Function SearchTxtFile(ByVal txtFileName As String, txtSearch As String) As Boolean

Dim fso As Object 'Scripting.FileSystemObject
Dim myFile As Object 'Scripting.TextStream     
Dim ReadAllTextFile As Variant

    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Open the file for input.
    Set myFile = fso.OpenTextFile(txtFileName, ForReading)

    ' Read from the file.
    If myFile.AtEndOfStream Then
        ReadAllTextFile = ""
    Else
        ReadAllTextFile = myFile.ReadAll
    End If

    If InStr(1, ReadAllTextFile, txtSearch, vbTextCompare) > 0 Then
        SearchTxtFile = True
    Else
        SearchTxtFile = False
    End If

End Function
Sub TestSearchFiles()

Dim colFiles As New Collection
Const txtPattern = "Business"
Const YOUR_START_DIR = "Your Dir"

    RecursiveDir colFiles, YOUR_START_DIR, "*.TXT", True

    Dim vFile As Variant
    For Each vFile In colFiles
        If SearchTxtFile(vFile, txtPattern) Then
            Debug.Print vFile
        End If
    Next vFile

End Sub

编辑以下代码将给出完整路径的路径名

Function GetDirectory(path)
   GetDirectory = Left(path, InStrRev(path, "\"))
End Function

将上面代码中的debug.print行改为

Debug.Print vFile, GetDirectory(vFile)

这就是你想要的吗？

EDIT2：改变搜索功能

Function SearchTxtFile(ByVal txtFileName As String, txtSearch() As Variant) As Boolean

Dim fso As Object    'Scripting.FileSystemObject
Dim myFile As Object    'Scripting.TextStream
Dim ReadAllTextFile As Variant
Dim i As Long

    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Open the file for input.
    Set myFile = fso.OpenTextFile(txtFileName, ForReading)

    ' Read from the file.
    If myFile.AtEndOfStream Then
        ReadAllTextFile = ""
    Else
        ReadAllTextFile = myFile.ReadAll
    End If

    For i = LBound(txtSearch) To UBound(txtSearch)
        If InStr(1, ReadAllTextFile, txtSearch(i), vbTextCompare) > 0 Then
            SearchTxtFile = True
        Else
            SearchTxtFile = False
            ' If just one string is not found
            ' no further search neccessary
            Exit Function
        End If
    Next

End Function

用

测试

Sub TestSearchFiles()

Dim colFiles As New Collection
Dim txtPattern() As Variant
Const YOUR_START_DIR = "Your directory here"

    txtPattern = Array("Pattern1", "Pattern2")
    RecursiveDir colFiles, YOUR_START_DIR, "*.TXT", True

    Dim vFile As Variant
    For Each vFile In colFiles
        If SearchTxtFile(vFile, txtPattern) Then
            Debug.Print vFile, GetDirectory(vFile)
        End If
    Next vFile

End Sub

用于在所有文件夹和子文件夹中搜索文本文件的vba代码

2 个答案: