如何以关键字突出显示整首诗

mmcha2002

如何以关键字突出显示整首诗，整首诗的判定标准为段落符号。只要有两个段落符号或超过两个，即为不同的诗。与字体无关~

duquancai

朋友，下次引用我写的代码，麻烦你还是注明一下“代码的出处”！
这次我再写一下你这个需求，详见如下代码：

1. Sub test()
   
2.     Dim findtext As String, n As Integer, k, x As Long, a() As Long, p As Range
   
3.     findtext = InputBox("关键词" & vbCr & "多关键词格式：风,万" & vbCr & "一个关键词格式：风", , "刀,风")
   
4.     ActiveDocument.Content.HighlightColorIndex = wdNoHighlight
   
5.     If findtext = Empty Then Exit Sub
   
6.     k = Split(findtext, ","): n = UBound(k)
   
7.     With ActiveDocument.Content.Find
   
8.         Do While .Execute("^13{2,}", , , -1)
   
9.             With .Parent
   
10.                 m = m + 1: ReDim Preserve a(m)
    
11.                 a(m) = .Start: .Start = .End
    
12.             End With
    
13.         Loop
    
14.     End With
    
15.     a(m) = ActiveDocument.Range.End: a(0) = 0
    
16.     For i = 1 To m
    
17.         Set p = ActiveDocument.Range(a(i - 1), a(i)).Duplicate
    
18.         With ActiveDocument.Range(a(i - 1), a(i)).Find
    
19.             Do While .Execute(k(n))
    
20.                 With .Parent
    
21.                     If Not .InRange(p) Then Exit Do
    
22.                     .Expand wdSentence
    
23.                     .MoveEndWhile vbCr, wdBackward
    
24.                     If f(k, .Text, n) Then
    
25.                         If .Text Like "*[。！？……]" Then
    
26.                             p.HighlightColorIndex = wdYellow
    
27.                             x = x + 1: Exit Do
    
28.                         End If
    
29.                     End If
    
30.                     .Start = .End
    
31.                 End With
    
32.             Loop
    
33.         End With
    
34.     Next
    
35.     MsgBox IIf(x > 0, "找到：" & x & "首诗并标记！", "没有找到符合要求的！")
    
36. End Sub
    
37. Function f(k, ByVal sr As String, ByVal n As Integer) As Boolean
    
38.     Dim x As Integer
    
39.     If n = 0 Then f = True: Exit Function
    
40.     Do While x <= n - 1
    
41.         If InStr(sr, k(x)) = 0 Then Exit Do
    
42.         x = x + 1
    
43.     Loop
    
44.     If x = n Then f = True
    
45. End Function

复制代码

mmcha2002

duquancai 发表于 2018-4-21 00:21
朋友，下次引用我写的代码，麻烦你还是注明一下“代码的出处”！
这次我再写一下你这个需求，详见如下代码 ...

谢谢您，下次一定记得注出处。

还想请问一下，代码的这部分是不是可以删除的？因为把您给的两个代码同时放在宏里面后，在运行其中一个的时候，会提示“出现二义性的名称”，一定要删除其中一个，不知道删除之后，会不会影响到运行代码的结果？

Function f(k, ByVal sr As String, ByVal n As Integer) As Boolean
    Dim x As Integer
    If n = 0 Then f = True: Exit Function
    Do While x <= n - 1
        If InStr(sr, k(x)) = 0 Then Exit Do
        x = x + 1
    Loop
    If x = n Then f = True
End Function

mmcha2002

duquancai 发表于 2018-4-21 00:21
朋友，下次引用我写的代码，麻烦你还是注明一下“代码的出处”！
这次我再写一下你这个需求，详见如下代码 ...

亲，在这个文件运行代码的时候，如果我输入“日暮”两个字，有两首诗无法突出显示。其中一首是“巴女谣”那首诗

巴女谣

[唐]于鹄

巴女骑牛唱竹枝，藕丝菱叶傍江时。不愁日暮还家错，记得芭蕉出槿篱。

还有一首

钓鱼湾

[唐]储光羲

垂钓绿湾春，春深杏花乱。

潭清疑水浅，荷动知鱼散。

日暮待情人，维舟绿杨岸。

这两首诗都有“日暮”二字，但无法突出显示。

但如果把诗单独放在一个文档的话，又可以显示。不知道是何原因？