How to loop through files in a folder? - vba

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