Word VBA：查找行并替换字体

Question

我写了一个VBA Word宏，它读取一个.txt文件，将其复制并粘贴到Word文档中，设置一种新字体。

所有工作正常！现在我想强调一些bold + italic字体的特定行，但我无法弄清楚一个工作解决方案。

特定行以特定词开头（例如Simulation Nr.xxx），或者以某些词开头，但它们有很长的一系列空格（例如Turbine）。

我该如何解决问题？

---

P.s .:这里是将.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.开始，以粗体和斜体更换整个线字体。

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 

请注意，我对要搜索的字符串进行了硬编码，您可以将其设置为函数参数。