vba - 如何遍历文件夹中的文件？

Question

我正在尝试循环我的 Dir 子例程，而不是重新复制代码。

该代码提示用户输入搜索词。

文档中给出了计数。黑色（1 次）、红色（2 次）或粗体红色（3 次以上）。

文件中的图像大小加倍。如果没有图像，则 MsgBox 会显示“文件中没有图像”。

要使用该程序修改多个文档，我需要输入一个目录（Dir），然后循环浏览该目录的文件。

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

标签： vbaloopsms-word

Answer 1

这就是我的意思-您的主要 Sub 获取用户输入并循环文件，但其他任务被拆分为离散的 Subs/Functions。

已编译，但未经测试，因此您可能需要修复一些问题...

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