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

Answer 1

这就是我的意思-您的主Sub得到用户输入并循环访问文件，但是其他任务被分解为离散的Subs / Function。

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

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

尝试使用VBA-新手

1 个答案: