查找特定格式段落的VBA

13907933959 · 发表于 2018-3-18 15:51

413191246se 发表于 2018-3-18 14:11
....这个”

师傅好！
啊、是这样呀！谢谢师傅的详释！

13907933959 · 发表于 2018-3-18 15:52

duquancai 发表于 2018-3-18 10:37

杜前辈好！
OK了！谢谢！

leedun · 发表于 2018-3-24 20:14

duquancai 发表于 2018-3-18 10:37

杜先生，如果要设置字体段落的上一段是表格就不完美了

413191246se · 发表于 2018-3-25 02:10

* 以下不太完美的《自动排版》代码仅供楼主参考：（提请特别注意《标题2345》自动设置宏，即Title2345）

Sub 公文()
Dim doc As Document, t As Table, j As Long, k As Long
Set doc = ActiveDocument
ActiveWindow.View.Type = wdPrintView
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
With doc
With .Content.Find
.Execute "^13", , , 0, , , , , , "^p", 2
.Execute "^11", , , 0, , , , , , "^p", 2
.Parent.ListFormat.ConvertNumbersToText
End With
If .Tables.Count = 0 Then
.Select
正文样式
Else
For Each t In .Tables
With t.Range
.Rows.WrapAroundText = False
.Rows.Alignment = wdAlignRowCenter
.Font.Name = "仿宋_GB2312"
.Font.Name = "Times New Roman"
.Font.Color = wdColorDarkRed
End With
Next
If .Paragraphs(1).Range.Information(wdWithInTable) = False Then
.Tables(1).Range.Previous.Select
Selection.HomeKey unit:=wdStory, Extend:=wdExtend
Selection.MoveEnd unit:=wdCharacter, Count:=1
正文样式
End If
k = .Tables.Count
For j = 1 To k
If j = k Then Exit For
.Range(Start:=.Tables(j).Range.End, End:=.Tables(j + 1).Range.Start).Select
正文样式
Next j
.Tables(k).Range.Next.Select
Selection.EndKey unit:=wdStory, Extend:=wdExtend
正文样式
End If
End With
Title2345
Auto1
Selection.HomeKey unit:=wdStory
End Sub
Sub 正文样式()
Dim i As Paragraph, r As Range
With Selection
.ClearFormatting
CommandBars.FindControl(ID:=122).Execute
CommandBars.FindControl(ID:=123).Execute
With .Font
.Name = "仿宋_GB2312"
.Name = "Times New Roman"
.Size = 16
.Color = wdColorBlue
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.LineSpacing = LinesToPoints(1.25)
.CharacterUnitFirstLineIndent = 2
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
Set r = .Range
For Each i In r.Paragraphs
If Len(i.Range) = 1 And Asc(i.Range) = 13 Then i.Range.Delete
Next
End With
End Sub
Sub Auto1()
With ActiveDocument.Paragraphs(1).Range
.InsertParagraphAfter
.InsertParagraphBefore
.Style = wdStyleHeading1
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.SpaceBefore = 0
.SpaceAfter = 0
.LineSpacing = LinesToPoints(1.15)
.Alignment = wdAlignParagraphCenter
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
.Paragraphs(1).Range.Font.Size = 21
.Paragraphs(3).Range.Font.Size = 26
End With
End Sub
Sub Title2345()
Dim mt, reg As Object, n&, m&, L&, ostr$, sr$, r1$, r2$, r3$, r4$
ostr = Replace(ActiveDocument.Content, Chr(7), "")
sr = "一二三四五六七八九十百零千〇"
r1 = "^[" & sr & "]+、"
r2 = "^[(（]\s*[" & sr & "]+\s*[)）]"
r3 = "^\d+[、.．]"
r4 = "^[(（]\s*\d+\s*[)）]"
Set reg = CreateObject("vbscript.regexp")
With reg
.Global = True
.MultiLine = True
.Pattern = "" & r2 & "|" & r1 & "|" & r4 & "|" & r3 & ""
For Each mt In .Execute(ostr)
m = mt.FirstIndex
n = mt.Length
With ActiveDocument.Range(m, m + n)
If Not .Information(wdWithInTable) Then
.Expand 4
L = Len(.Text)
.Collapse
If .MoveWhile(sr, L) > 0 Then
.Expand 4
.Style = "标题 2"
.Font.ColorIndex = 6
ElseIf .MoveWhile("(（", L) > 0 Then
If .MoveWhile(sr, L) > 0 Then
.Expand 4
.Style = "标题 3"
With .Font
.Name = "楷体_GB2312"
.Name = "Times New Roman"
.ColorIndex = 5
End With
Else
.Expand 4
.Style = "标题 5"
With .Font
.Name = "仿宋_GB2312"
.Name = "Times New Roman"
.ColorIndex = 12
End With
End If
Else
.Expand 4
.Style = "标题 4"
With .Font
.Name = "仿宋_GB2312"
.Name = "Times New Roman"
.ColorIndex = 11
End With
End If
If .Sentences.Count = 1 Then
' If v Like "*[。：；，、！？…—.:;,!?]?" Then .Characters.Last.Previous.Delete
Else
With .Font
.Name = "仿宋_GB2312"
.Name = "Times New Roman"
.Bold = False
.Color = wdColorBlue
End With
With .Sentences(1).Font
.Bold = True
.Color = wdColorBrown
End With
End If
With .Font
.Size = 16
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.SpaceBefore = 0
.SpaceAfter = 0
.LineSpacing = LinesToPoints(1.25)
.CharacterUnitFirstLineIndent = 2
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
.KeepWithNext = False
.KeepTogether = False
End With
End If
End With
Next
End With
End Sub

复制代码

ke3088 · 发表于 2018-3-25 11:10

413191246se 发表于 2018-3-25 02:10
* 以下不太完美的《自动排版》代码仅供楼主参考：（提请特别注意《标题2345》自动设置宏，即Title2345）

好的，谢谢！413191246se老师

		自动登录	找回密码
密码			免费注册

[求助] 查找特定格式段落的VBA