Word VBA：查找行並替換字體

Question

我編寫了一個VBA Word宏，該宏讀取.txt文件，將其復制並粘貼到設置新字體的Word文檔中。

一切正常！ 現在，我想用bold + italic字體突出顯示某些特定的行，但是我無法找出一個可行的解決方案。

特定的行以特定的單詞開頭（例如Simulation Nr.xxx ），或者以某些單詞開頭，但是隨后它們具有很長的一系列空格（例如Turbine ）。

我該如何解決這個問題？

---

ps：這里是將.txt文件復制/粘貼到Word文檔中的工作代碼。

Sub ACTUS_Table_Converter()

Dim pName As String
Dim bDoc As Document
Dim AppPath, ThisPath As String
Dim Rng As Range

ThisPath = ActiveDocument.Path
pName = ActiveDocument.Name

With Dialogs(wdDialogFileOpen)
    If .Display Then
        If .Name <> "" Then
            Set bDoc = Documents.Open(.Name)
            AppPath = bDoc.Path
        End If
    Else
        MsgBox "No file selected"
    End If
End With

Call ReplaceAllxSymbolsWithySymbols
Call ChangeFormat

Selection.Copy
Windows(pName).Activate
Selection.Paste
Selection.Collapse
bDoc.Close savechanges:=False

End Sub

Sub ChangeFormat()

Selection.WholeStory
With Selection.Font
    .Name = "Courier New"
    .Size = 6
End With

End Sub

Sub ReplaceAllxSymbolsWithySymbols()

'Call the main "ReplaceAllSymbols" macro (below),
'and tell it which character code  and font to search for, and which to replace with

Call ReplaceAllSymbols(FindChar:=ChrW(-141), FindFont:="(normal text)", _
        ReplaceChar:=ChrW(179), ReplaceFont:="(normal text)")
Call ReplaceAllSymbols(FindChar:=ChrW(-142), FindFont:="(normal text)", _
        ReplaceChar:=ChrW(178), ReplaceFont:="(normal text)")
Call ReplaceAllSymbols(FindChar:=ChrW(-144), FindFont:="(normal text)", _
        ReplaceChar:=ChrW(176), ReplaceFont:="(normal text)")
Call ReplaceAllSymbols(FindChar:="°", FindFont:="(normal text)", _
        ReplaceChar:="", ReplaceFont:="(normal text)")

End Sub

Sub ReplaceAllSymbols(FindChar As String, FindFont As String, _
    ReplaceChar As String, ReplaceFont As String)

Dim FoundFont As String, OriginalRange As Range, strFound As Boolean
Application.ScreenUpdating = False

Set OriginalRange = Selection.Range
'start at beginning of document
ActiveDocument.Range(0, 0).Select

strFound = False
If ReplaceChar = "" Then
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = FindChar
    .Replacement.Text = ReplaceChar
    .Replacement.Font.Name = "Courier New"
    .Replacement.Font.Size = 6
    .MatchCase = True
End With
If Selection.Find.Execute Then
    Selection.Delete Unit:=wdCharacter, Count:=2
    Selection.TypeText ("°C")
End If
Else
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = FindChar
    .Replacement.Text = ReplaceChar
    .Replacement.Font.Name = "Courier New"
    .Replacement.Font.Size = 6
    .MatchCase = True
    .Execute Replace:=wdReplaceAll
End With
End If

OriginalRange.Select

Set OriginalRange = Nothing
Application.ScreenUpdating = True

Selection.Collapse

End Sub

Answer 1

以下代碼應在文檔中運行，以Simulation Nr.查找行開頭Simulation Nr. 並將整行字體替換為粗體和斜體。

Sub ReplaceLinesStartWith()

Dim startingWord As String
'the string to search for
startingWord = "Simulation Nr."

Dim myRange As range
'Will change selection to the document start
Set myRange = ActiveDocument.range(ActiveDocument.range.Start, ActiveDocument.range.Start)
myRange.Select

While Selection.End < ActiveDocument.range.End
   If Left(Selection.Text, Len(startingWord)) = startingWord Then
        With Selection.Font
            .Bold = True
            .Italic = True
        End With
    End If

    Selection.MoveDown Unit:=wdLine
    Selection.Expand wdLine

Wend

End Sub

請注意，我對要搜索的字符串進行了硬編碼，您可以將其設置為函數參數。