How to loop through files in a folder?

Question

I'm attempting to Loop my Dir subroutine rather than copying the code all over again.

The code prompts a user for a search word.

A count is given in the document. Black (1 time), red (2 times), or bolded red (3+ times).

Images in the file are doubled in size. If there are no images a MsgBox says "no images in file".

To modify multiple documents with this program, I need to input a directory (Dir) and then loop through the files of the directory.

Sub austinolson()
    Dim WordInput As String
    Dim WordCount As Integer
    Dim Range As word.Range
    WordInput = InputBox("Search for a word")
    
    'Everything below this code
    
    Set Range = ActiveDocument.Content
    WordCount = 0
    With Range.Find
        .ClearFormatting
        .Format = False
        .Forward = True
        .MatchWholeWord = True
        .Text = WordInput
        .Wrap = wdFindStop
        .Execute
        Do While .Found
            WordCount = WordCount + 1
            Range.Collapse word.WdCollapseDirection.wdCollapseEnd
            .Execute
        Loop
    End With
        MsgBox ("The word: '" & "" & WordInput & "" & "' shows up " & WordCount & " times in the document")

    ActiveDocument.Content.InsertParagraphAfter
    Set Range = ActiveDocument.Content
    Range.Collapse word.WdCollapseDirection.wdCollapseEnd
    Range.Text = "Number occurrences: " & WordCount
    
    If WordCount >= 3 Then
        Range.Font.ColorIndex = wdRed
        Range.Font.Bold = True
        
    ElseIf WordCount >= 2 Then
        Range.Font.ColorIndex = wdRed
        Range.Font.Bold = False
        
    Else
        Range.Font.ColorIndex = wdBlack
        Range.Font.Bold = False
    End If

    'Inline shape count below'
    Dim h As Long
    Dim w As Long
    Dim rng As Range
    Dim Ishape As InlineShape

    Set rng = ActiveDocument.Content

    If rng.InlineShapes.Count = 0 Then
        MsgBox "No images to modify"
    End If

    For Each Ishape In ActiveDocument.InlineShapes
        h = Ishape.Height
        w = Ishape.Width

        Ishape.Height = 2 * h
        Ishape.Height = 2 * w
    Next Ishape

    'location input:

    Dim Path As String
    Dim currentFilename As String
    currentFilename = ""
    Path = ""
    
    Do While (Path = "")
        Path = InputBox("Location of documents e.g. C:\203\: ")
        If (Path = "") Then
            MsgBox ("No location entered, ending program")
        Exit Sub
        End If
    Loop

    'Everything above this code:

    currentFilename = Dir(Path & "*.docx")
    Do While (currentFilename <> "")
        MsgBox (currentFilename)
        If (currentFilename <> "") Then
            Documents.Open (Path & currentFilename)
            '
            ' Need to apply loop inbetween "Above and below code" HERE to the opened word documents.
            '
            ActiveDocument.Close (wdSaveChanges)
        End If
        currentFilename = Dir
    Loop

End Sub

Answer 1

Here's what I mean - your main Sub gets user input and loops over the files, but the other tasks are split out into discrete Subs/Functions.

Compiled, but not tested, so you may need to fix some things...

Sub MainProgram()

    Dim WordInput As String
    Dim WordCount As Long, ImageCount As Long
    Dim doc As Document

    Dim Path As String
    Dim currentFilename As String
    currentFilename = ""

    'get a path from the user
    Path = Trim(InputBox("Location of documents e.g. 'C:\203\'"))
    If Path = "" Then
        MsgBox "No location entered, ending program"
        Exit Sub
    End If
    If Right(Path, 1) <> "\" Then Path = Path & "\" 'ensure trailing slash

    'get the search word
    WordInput = Trim(InputBox("Search for a word"))
    If Len(WordInput) = 0 Then Exit Sub 'maybe add a message here...

    'start looping over the folder
    currentFilename = Dir(Path & "*.docx")
    Do While currentFilename <> ""

        Set doc = Documents.Open(Path & currentFilename)

        WordCount = CountTheWord(doc, WordInput) 'count the words

        TagWordCount doc, WordInput, WordCount   'insert count to doc

        ImageCount = ResizeInlineShapes(doc)

        Debug.Print "'" & WordInput & "' shows up " & WordCount & " times in '" & doc.Name & "'"
        Debug.Print "...and there were " & ImageCount & " images resized"

        doc.Close wdSaveChanges
        currentFilename = Dir
    Loop

End Sub

Function CountTheWord(doc As Document, theWord As String) As Long
    Dim WordCount As Long, rng As Range

    Set rng = doc.Content
    WordCount = 0
    With rng.Find
        .ClearFormatting
        .Format = False
        .Forward = True
        .MatchWholeWord = True
        .Text = theWord
        .Wrap = wdFindStop
        .Execute
        Do While .Found
            WordCount = WordCount + 1
            rng.Collapse wdCollapseEnd
            .Execute
        Loop
    End With
    CountTheWord = WordCount
End Function

'append a word count to the end of the document
Sub TagWordCount(doc As Document, theWord As String, theCount As Long)
    Dim rng As Range
    doc.Content.InsertParagraphAfter
    Set rng = doc.Content
    rng.Collapse wdCollapseEnd
    rng.Text = "Number occurrences for '" & theWord & "': " & theCount
    rng.Font.Bold = (theCount >= 3)
    rng.Font.ColorIndex = IIf(theCount >= 2, wdRed, wdBlack)
End Sub

Function ResizeInlineShapes(doc As Document) As Long
    Dim rv As Long, Ishape As InlineShape

    For Each Ishape In doc.InlineShapes
        Ishape.Height = 2 * Ishape.Height
        Ishape.Height = 2 * Ishape.Height
        rv = rv + 1
    Next Ishape

    ResizeInlineShapes = rv '<< number of shapes resized
End Function