使用vba格式化Word文档

时间：2014-08-12 12:55:12

标签： vba word-vba

我有一份包含当前格式化文件的文件

标题

字幕

H1

SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText

H2

SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText

H3

SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText

H4

SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText

这里的标题H1，H2，H3，H4是粗体 我刚刚将示例文本放在标题

下面的pragraph的位置

我需要将该文档格式化为

标题字幕

  • H1：SampleText SampleText SampleText SampleText SampleText SampleTextSampleTextSampleText SampleText SampleText SampleText SampleText（para1）
  • H2：SampleText SampleText SampleText SampleText SampleText SampleText   SampleText SampleText SampleText SampleText SampleText SampleText（para2）
  • H3：SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText（para3）
  • H4：SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText（para4）

目前我在标题的开头添加*，在结尾添加冒号。使用它们作为参考我正在形成段落。 这是我目前正在思考的代码

    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

但代码进入无限循环。

2 个答案:

答案 0 :(得分：2)

我认为你的问题是你试图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

答案 1 :(得分：0)

经过大量的反复试验后，我找到了解决方案：

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
相关问题
最新问题