Microsoft Office Forums - View Single Post - [Solved] word vba Search files for string and save found filenames to new textfile

gmayor · 05-08-2016, 08:52 PM

I have lost track of what we are trying to do. The first example I quoted will work for text files, the following does the same thing for DOC/DOCX format files (using your getfolder function)

Code:

Option Explicit
Sub Find_files_with_string_save_filenames()
Dim wdDoc As Document
Dim oRng As Range
Dim strFile As String
Dim strPath As String
Dim fso As Object
Dim oFile As Object
Const strFindText As String = "first"

    strPath = GetFolder
    If strPath = "" Then Exit Sub
    On Error Resume Next
    Kill strPath & "\f9.txt"
    On Error GoTo 0

    strFile = Dir(strPath & "\*.doc", vbNormal)

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFile = fso.CreateTextFile(strPath & "\f9.txt")
    While strFile <> ""
        Set wdDoc = Documents.Open(Filename:=strPath & "\" & strFile, _
                                   AddToRecentFiles:=False, _
                                   ReadOnly:=True, _
                                   Visible:=False)
        For Each oRng In wdDoc.StoryRanges 'It's a document so look in all story ranges
            With oRng.Find
                .Font.Bold = True 'Find the string only if it is bold
                Do While .Execute(FindText:=strFindText)
                    oFile.WriteLine strFile
                    Exit Do    'search text found so stop looking
                    Exit For    'and don't look in any more ranges
                Loop
            End With
            DoEvents
        Next oRng
        wdDoc.Close 0
        strFile = Dir$()
    Wend
    oFile.Close
    MsgBox "Completed...", vbInformation
lbl_Exit:
    Set oRng = Nothing
    Set wdDoc = Nothing
    Set fso = Nothing
    Set oFile = Nothing
    Exit Sub
End Sub