[JavaScript知识库]Word VBA 实例收集

批量对关键字打标记

Option Explicit
 
Sub 遍历文件夹中的文档()
     
    Dim CurrPath$, CurrFile$, currDoc As Document, keyArray() As String, fileNameExtension As String
    CurrPath = ThisDocument.Path & "\"
    CurrFile = Dir(CurrPath)

    Do Until CurrFile = ""
        If CurrFile <> ThisDocument.Name And (Right(CurrFile, 5) = ".docx" Or Right(CurrFile, 4) = ".doc") Then
            Set currDoc = Documents.Open(CurrPath & CurrFile)
            Call 对关键字打标记(currDoc, ThisDocument)
            DoEvents ' 保存前想看一眼
            currDoc.Save
            currDoc.Close True
            Set currDoc = Nothing
        End If
        CurrFile = Dir()
    Loop
 
End Sub

Sub 对关键字打标记(doc As Document, MainDoc As Document)
    Dim i As Integer, keyArrLen As Integer, keyArray() As String, styleName As String
    
    keyArray = 获取关键字(MainDoc)
    keyArrLen = UBound(keyArray)

    styleName = 创建样式(doc)

    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.style = styleName
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue

        ' 遍历查找关键字，并标示
        For i = 0 To keyArrLen
            .Text = keyArray(i)
            .Execute Replace:=wdReplaceAll
        Next
    End With
End Sub

Function 创建样式(doc As Document)
    ' 判断样式，不存在则创建
    Dim flag As Boolean, syte As style, styleName As String
    styleName = "关键字"
    
    flag = True
    For Each syte In doc.Styles
        If syte.NameLocal = styleName Then
            flag = False
        End If
    Next
    
    If flag Then
        ActiveDocument.Styles.Add Name:=styleName, Type:=wdStyleTypeCharacter
        With ActiveDocument.Styles(styleName).Font
            .NameFarEast = "微软雅黑"
            .Bold = True
            .Color = wdColorYellow
            .Shading.ForegroundPatternColor = wdColorAutomatic
            .Shading.BackgroundPatternColor = wdColorRed
        End With
    End If
    
    创建样式 = styleName
End Function

Function 获取关键字(doc As Document)
    Dim keyArray() As String, arrLen As Integer, pgs As Paragraphs, i As Integer
    ' 取当前文档所有段落
    Set pgs = doc.Paragraphs
    arrLen = pgs.Count - 1
    ' 重置动态数组的长度
    ReDim keyArray(arrLen) As String

    ' 遍历段落，将文字加入数组
    For i = 0 To arrLen
        keyArray(i) = Replace(Trim(pgs(i + 1).Range.Text), vbCr, "")
    Next

    获取关键字 = keyArray
End Function