问题：

使用vba的Word文档格式

章茂

2023-03-14

我有一个当前格式的文档

标题

字幕

样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本样本文本

在这里，段落标题H1、H2、H3、H4是粗体的，我刚刚用示例文本代替了标题下方的杂注文字

我需要那个医生的格式

标题字幕

H1:SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText（para1）
H2:SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText（para2）
H3:SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText-SampleText（para3）
H4: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个答案

段铭晨

2023-03-14

经过多次尝试和错误，我终于找到了解决方案：

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

濮阳翔

2023-03-14

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

你可以考虑另一种方法。

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

类似资料：

使用VBA的Word文档迭代

我有一个word文档，其中包含许多由html标记定义的html文档。我想创建一个数组或范围集合，每个范围由一个html文档组成。例如，以下是Word文档：等等。我想用一系列范围来填充rngHTMLDocs（）As Range，每个范围包含每个打开和关闭html标记中的文本。我创建了以下代码，试图遍历定义这些范围的整个文档，但它只继续选择超文本标记语言Doc 1。我想我可能以错误的方式接近整个迭
用VBA保护Word文档

我想用vba来保护我的word文档。的确，这是可能的，但我已经通过以下链接搜索了如何取消文档保护： http://www.aurelp.com/2015/04/01/how-to-unlock-a-microsoft-word-document-step-by-stepsolved/ 有没有其他方法可以成功地保护文档不被未经授权的用户使用？
使用vba将word文档的内容复制到另一个word文档中

我已经很多年没有使用VB了，所以如果这是显而易见的，请原谅我。我正在尝试编写一个word vba宏，以便在模板中使用，该模板将显示一个userform，然后导入fileA的内容。docx，fileB。docx或fileC。docx取决于用户表单。（之后我将使用书签填写一些表单数据，我不知道这是否相关）。文件A、B和C将包含一些基本格式（如列表）的文本，但没有什么特别之处。我在网上看到的解决方案可
使用VBA从Word文档中提取图像

我需要循环一些word文档，并从word文档中提取图像，并将其保存在单独的文件夹中。我尝试过将它们保存为超文本标记语言文档的方法，但它不太适合我的需求。现在，我使用inlineshapes对象循环浏览图像，然后将它们复制粘贴到publisher文档上，然后将它们保存为图像。但是，在运行脚本时，我会遇到运行时自动化错误。对于使用Publisher运行时库，我尝试了早期绑定和晚期绑定，但都遇到了错误
使用Excel VBA解析Word文档的完整内容

我想编写一个通用方法，通过循环段落和形状来提取从word文档到文本文件的所有内容。我能够使用下面的代码解析90%的文档。但是，此代码不会读取少数表中的内容。我无法从MS word文档中提取表格中的少量文本。这个问题只涉及一些文本和表格，我可以用我的代码阅读文档中的大部分内容。 Word文档位于以下链接中- https://drive.google.com/file/d/0B1C7jj9dLG2
使用excel VBA代码将PDF转换为Word文档

每个人。我需要一个VBA代码来将excel数据转换为PDf到word doc，我写了一个宏，将excel打印为pdf，但现在我想从该pdf打印为word，所以简短的版本，Excel到PDF到Word。所有这些都是为了我想保留excel数据的格式

使用vba的Word文档格式

共有2个答案

相关问答

相关文章

相关阅读

相关工具

相关文档