使用 vba 格式化 Word 文档

Question

我有一个当前格式的文档

---

标题

副标题

上半年

示例文本示例文本示例文本示例文本 样本文本样本文本样本文本样本文本 示例文本示例文本示例文本示例文本

H2

示例文本示例文本示例文本示例文本 样本文本样本文本样本文本样本文本 示例文本示例文本示例文本示例文本

H3

示例文本示例文本示例文本示例文本 样本文本样本文本样本文本样本文本 示例文本示例文本示例文本示例文本

H4

示例文本示例文本示例文本示例文本 样本文本样本文本样本文本样本文本 示例文本示例文本示例文本示例文本

---

这里的段落标题 H1,H2,H3,H4 是粗体 我刚刚用示例文本代替了标题下方显示的段落

我需要将该文档格式化为

---

标题副标题

• H1：SampleText SampleText SampleText SampleText SampleText SampleTextSampleTextSampleText SampleText SampleText SampleText SampleText(para1)
• H2：示例文本示例文本示例文本示例文本示例文本示例文本 SampleText SampleText SampleText SampleText SampleText SampleText(para2)
• H3：示例文本示例文本示例文本示例文本示例文本示例文本 SampleText SampleText SampleText SampleText SampleText SampleText(para3)
• H4：示例文本示例文本示例文本示例文本示例文本示例文本 SampleText SampleText SampleText SampleText SampleText SampleText(para4)​​li>

---

目前我在标题的开头添加一个 * 并在末尾添加一个冒号。使用它们作为参考我正在格式化段落。 这是我目前正在考虑的代码

    Sub wordfor()
    Dim oRng As Word.Range
    Dim flag As Integer
    Set oRng = ActiveDocument.Content

With oRng.Find
   .ClearFormatting
   .Text = ""
   .Font.Bold = True
        While .Execute
           oRng.Text = "*" + oRng.Text
           oRng.Font.Underline = True
           oRng.Text = oRng.Text + ":"
           oRng.Collapse wdCollapseEnd
        Wend
End With
Selection.HomeKey Unit:=wdStory
Do Until Selection.Information(wdFirstCharacterLineNumber) =   ThisDocument.BuiltInDocumentProperties("Number of lines").Value
'MsgBox (ThisDocument.BuiltInDocumentProperties("Number of lines").Value)
     Selection.HomeKey Unit:=wdLine
     Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
     If Selection.Text = "*" Then
         Selection.EndKey Unit:=wdLine
         Selection.TypeText Text:=" "
         Selection.Delete Unit:=wdCharacter, Count:=1

       Else
       Selection.MoveUp Unit:=wdLine, Count:=1
       Selection.EndKey Unit:=wdLine
       Selection.TypeText Text:=" "
       Selection.Delete Unit:=wdCharacter, Count:=1
       End If
Selection.MoveDown Unit:=wdLine, Count:=1
 Selection.MoveDown Unit:=wdLine, Count:=1
  Loop
    Selection.MoveUp Unit:=wdLine, Count:=1
         Selection.EndKey Unit:=wdLine
         Selection.TypeText Text:=" "
         Selection.Delete Unit:=wdCharacter, Count:=1
     Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .Text = "*"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
     End With
Selection.Find.Execute Replace:=wdReplaceAll

Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.EndKey Unit:=wdLine
Selection.TypeParagraph
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
With ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1)
    .NumberFormat = ChrW(61623)
    .TrailingCharacter = wdTrailingTab
    .NumberStyle = wdListNumberStyleBullet
    .NumberPosition = InchesToPoints(0.25)
    .Alignment = wdListLevelAlignLeft
    .TextPosition = InchesToPoints(0.5)
    .TabPosition = InchesToPoints(0.5)
    .ResetOnHigher = 0
    .StartAt = 1
    With .Font
        .Bold = wdUndefined
        .Italic = wdUndefined
        .StrikeThrough = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .Shadow = wdUndefined
        .Outline = wdUndefined
        .Emboss = wdUndefined
        .Engrave = wdUndefined
        .AllCaps = wdUndefined
        .Hidden = wdUndefined
        .Underline = wdUndefined
        .Color = wdUndefined
        .Size = wdUndefined
        .Animation = wdUndefined
        .DoubleStrikeThrough = wdUndefined
        .Name = "Symbol"
    End With
    .LinkedStyle = ""
End With
ListGalleries(wdBulletGallery).ListTemplates(1).Name = ""
Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _
    wdBulletGallery).ListTemplates(1), ContinuePreviousList:=False, ApplyTo:= _
    wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior

End Sub

但是代码进入了无限循环。

Answer 1

我认为你的问题是你试图Find 一个星号，它是一个通配符，因此总能找到一些东西。如果您搜索 ~*，波浪号会转义通配符。

您可能会考虑另一种方法。

Sub WordReFormat()

    Dim para As Paragraph

    For Each para In ThisDocument.Paragraphs
        If para.Range.Bold Then
            para.Range.Bold = False
            para.Range.InsertAfter ": "
            para.Range.Characters(para.Range.Characters.Count).Delete wdCharacter, 1
            para.Range.InsertBefore " * "
            para.Range.AutoFormat
        End If
    Next para

End Sub

Answer 2

经过大量的尝试和错误，我终于找到了解决方案：

Sub Word_Format()
Call copy_clipboard
Call create_wildcards
Call remove_spaces
Call separate_bpts
Call underline
Call add_Bullets
Call remove_wildcards
End Sub

Function copy_clipboard()
Dim rngFrom, rngTo
rngFrom = Selection.Start
Selection.PasteAndFormat wdFormatOriginalFormatting
rngTo = Selection.End
ActiveDocument.Range(rngFrom, rngTo).Select
ActiveDocument.Paragraphs(4).Range.Select
Selection.CopyFormat
ActiveDocument.Paragraphs(1).Range.Select  
Selection.PasteFormat
ActiveDocument.Paragraphs(2).Range.Select
Selection.PasteFormat
End Function

Function create_wildcards()
Dim oRng As Word.Range
Dim flag As Integer
Set oRng = ActiveDocument.Content

With oRng.Find
.ClearFormatting
.Text = ""
.Font.Bold = True
    While .Execute
        oRng.InsertBefore Text:="?"
        oRng.InsertAfter Text:=":}"
        oRng.Select
        'Selection.TypeBackspace
        'oRng.Text = oRng.Text + ": "
        oRng.Font.underline = True
        oRng.Collapse wdCollapseEnd
    Wend
End With
End Function

Function remove_spaces()
Dim selectedText As String
Dim textLength As Integer

Selection.WholeStory
selectedText = Selection.Text

' If no text is selected, this prevents this subroutine from typing another
' copy of the character following the cursor into the document
    If Len(selectedText) <= 1 Then
Exit Function
    End If

' Replace all carriage returns and line feeds in the selected text with spaces
selectedText = Replace(selectedText, vbCr, " ")
selectedText = Replace(selectedText, vbLf, " ")

' Get rid of repeated spaces
Do
    textLength = Len(selectedText)
    selectedText = Replace(selectedText, "  ", " ")
Loop While textLength <> Len(selectedText)

' Replace the selected text in the document with the modified text
Selection.TypeText (selectedText)

End Function

Function separate_bpts()
Dim oRng As Word.Range
Dim flag As Integer
Set oRng = ActiveDocument.Content

With oRng.Find
.ClearFormatting
.Text = "?"
    While .Execute
        oRng.Text = vbCrLf + oRng.Text
        oRng.Font.underline = True
         oRng.Collapse wdCollapseEnd
    Wend
End With

End Function

Function add_Bullets()
ActiveDocument.Select
Selection.HomeKey unit:=wdStory
Selection.EndKey unit:=wdLine, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.EndKey unit:=wdLine
Selection.TypeParagraph
Selection.MoveDown unit:=wdLine, Count:=1
Selection.EndKey unit:=wdStory, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("No Spacing")
With Selection.Font
.Name = Frutiger45Light
.Size = 9
End With
With ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1)
    .NumberFormat = ChrW(61623)
    .TrailingCharacter = wdTrailingTab
    .NumberStyle = wdListNumberStyleBullet
    .NumberPosition = InchesToPoints(0.25)
    .Alignment = wdListLevelAlignLeft
    .TextPosition = InchesToPoints(0.5)
    .TabPosition = wdUndefined
    .ResetOnHigher = 0
    .StartAt = 1
    With .Font
        .Bold = wdUndefined
        .Italic = wdUndefined
        .StrikeThrough = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .Shadow = wdUndefined
        .Outline = wdUndefined
        .Emboss = wdUndefined
        .Engrave = wdUndefined
        .AllCaps = wdUndefined
        .Hidden = wdUndefined
        .underline = wdUndefined
        .Color = wdUndefined
        .Size = wdUndefined
        .Animation = wdUndefined
        .DoubleStrikeThrough = wdUndefined
        .Name = "Symbol"
    End With
    .LinkedStyle = ""
End With
ListGalleries(wdBulletGallery).ListTemplates(1).Name = ""
Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
    ListGalleries(wdBulletGallery).ListTemplates(1), ContinuePreviousList:= _
    False, ApplyTo:=wdListApplyToSelection, DefaultListBehavior:= _
    wdWord10ListBehavior

Selection.Range.ListFormat.ListIndent
Selection.Range.ListFormat.ListIndent

    Selection.MoveUp unit:=wdLine, Count:=1
    Selection.TypeBackspace
End Function

Function remove_wildcards()
ActiveDocument.Select
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = "?"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = "}"
    .Replacement.Text = " "
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = " :"
    .Replacement.Text = ":"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

End Function

Function underline()
Dim str As String
Dim openPos As Integer
Dim closePos As Integer
Dim midBit, temp As String
Dim para As Paragraph

For Each para In ActiveDocument.Paragraphs

str = para.Range.Text
openPos = InStr(str, "?")
closePos = InStr(str, "}")
If openPos = 0 And closePos = 0 Then
GoTo nxt
 Else
 midBit = Mid(str, openPos + 1, closePos - openPos - 1)
 Call und(midBit)
 End If
 nxt: Next para
 End Function

 Function und(ByVal st As String)
 Dim oRng As Word.Range
 Dim flag As Integer
 Set oRng = ActiveDocument.Content

 With oRng.Find
 .ClearFormatting
 .Text = st
    While .Execute
        oRng.Font.underline = True
         oRng.Collapse wdCollapseEnd
    Wend
 End With
 End Function