怎样找出文档中的所有词，并标记?

may158

找出文档中的所有两字词、三字词、四字词、多字词……找出后标记成不同于源文档的颜色或下划线都可以。

ming0018

你把所有的两字词、三字词、四字词、多字词例举出来后，写代码只需要几分钟。

ngcg

以下列的格式将欲检索的词语、单字或短语保存在一个以Unicode格式存盘的文档里
/国家/我们/一针见血/课/校友会/
文档的名称必须是myword.txt
将以下宏注入Word
打开欲检查的Word文档
运行MarkWord宏

Sub MarkWord()
  Dim LocPath As String
  Dim myCharSet As String
  Dim errMessage, myWord, Message As String
  Dim t As Date
  Dim i As Single
  Dim Title, aText, mStr, myCK As String
  Dim intResponse As Integer
  Dim myContent As Range
  Dim fs, fso, WSshell As Object
  Dim newDoc As Document
  
  Const MaxChar = 5
  Const adReadAll = -1
  myCharSet = "UTF-16"
  Const adTypeText = 2
  t = Now

  Selection.WholeStory
  Selection.Font.Color = wdColorBlack
  Selection.Collapse wdCollapseStart
  
  Title = ChrW$(&H6B63) & ChrW$(&H5411) & ChrW$(&H5206) & ChrW$(&H8BCD)
  
  Set WSshell = CreateObject("WScript.Shell")
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  With ActiveDocument
    If .Path = "" Then
      errMessage = ChrW$(&H5148) & ChrW$(&H5B58) & ChrW$(&H76D8) & ChrW$(&H540E) & ChrW$(&H624D) & ChrW$(&H7EDF) & ChrW$(&H8BA1)
      intResponse = WSshell.popup(errMessage, 5, Title, 48)
      Exit Sub
    End If
  End With
  
  LocPath = ActiveDocument.Path
  If VBA.Right(LocPath, 1) <> "\" Then LocPath = LocPath + "\"
  myWord = LocPath + "myword.txt"
  If Not fso.FileExists(myWord) Then
    Message = ChrW$(&H627E) + ChrW$(&H4E0D) + ChrW$(&H5230) + ChrW$(&H6587) + ChrW$(&H4EF6) & ChrW$(&H20) & vbCr & myWord
    intResponse = WSshell.popup(Message, 10, Title, 48)
    Exit Sub
  End If
   
  Application.ScreenUpdating = False

  Set fs = CreateObject("ADODB.Stream")
  fs.CharSet = myCharSet
  fs.Type = adTypeText
  fs.Open
  fs.LoadFromFile (myWord)
  myCK = fs.ReadText(adReadAll)
  
  Set myContent = ActiveDocument.Content
  If InStr(myContent, Chr(11)) > 0 Then myContent = Replace(myContent, Chr(11), Chr(13))
  aText = myContent

  Selection.HomeKey wdStory

  While VBA.Len(aText) >= 1
    For i = MaxChar To 1 Step -1
      If InStr(myCK, "/" & VBA.Left(aText, i) & "/") > 0 Then
        mStr = Left(aText, i)
        aText = VBA.Mid(aText, i + 1)
        Selection.MoveRight Unit:=wdCharacter, Count:=Len(mStr), Extend:=wdExtend
        Selection.Font.ColorIndex = wdRed
        Selection.Collapse wdCollapseEnd
        Exit For
      End If
      If i = 1 Then
        aText = VBA.Mid(aText, i + 1)
        Selection.MoveRight Unit:=wdCharacter, Count:=1
      End If
    Next
  Wend
  Application.ScreenUpdating = True
  Selection.HomeKey Unit:=wdStory
  
  Message = ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A)
  intResponse = WSshell.popup(Message & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
  fs.Close
  Set fs = Nothing
  Set fso = Nothing
  Set WSshell = Nothing
End Sub

may158

ngcg 发表于 2018-7-23 11:07
以下列的格式将欲检索的词语、单字或短语保存在一个以Unicode格式存盘的文档里
/国家/我们/一针见血/课/校 ...

谢谢，完全符合要求