|
|
楼主 |
发表于 2017-10-27 09:33
|
显示全部楼层
自己优化了一个
Sub 整理课程标题()
Dim i As Integer '循环执行
Dim myRange As Range
Dim oInlineShape As InlineShape, oShape As Shape
Dim myHeight As Single, myWidth As Single
Dim acon As New Collection
Dim apar As Paragraph
Dim starttime, endtime
Dim MyStr As String, YouStr As String
On Error Resume Next
starttime = Timer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'删除指定图片
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
myHeight = 23 '磅,必须以磅为单位,如以厘米等,则会在单位换算过程中出现误差
myWidth = 415 '磅
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'如 以磅为单位返回需要删除的图形的宽或者高
' MsgBox Selection.ShapeRange(1).Width
' MsgBox Selection.ShapeRange(1).Height
' MsgBox Selection.InlineShapes(1).Width
' MsgBox Selection.InlineShapes(1).Height
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False
'删除指定高度宽度的嵌入式图形
For Each oInlineShape In ActiveDocument.InlineShapes
If oInlineShape.Height = myHeight And oInlineShape.Width = myWidth Then oInlineShape.Delete
Next
'删除指定宽度高度的浮动式图形
For Each oShape In ActiveDocument.Shapes
If oShape.Height = myHeight And oShape.Width = myWidth Then oShape.Delete
Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'替换全角空格为半角空格
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Selection.Type = wdSelectionIP Then Selection.WholeStory
Set myRange = Selection.Range
myRange.Find.Execute FindText:=" ", replacewith:=" ", Replace:=wdReplaceAll '替换所有全角空格为半角空格
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'设置标题
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
MyStr = "第"
YouStr = "一二三四五六七八九十"
With ActiveDocument
For Each apar In .Paragraphs
If apar.Range.Information(wdWithInTable) = False Then
If apar.Range.Find.Execute(FindText:="第[一二三四五六七八九十]{1,}章 ", Forward:=True, MatchWildcards:=True) = True And InStr(MyStr, ActiveDocument.Range(apar.Range.Start, apar.Range.Start + 1).Text) > 0 Then
'.Style = wdStyleHeading3
With apar.Range
.Font.Name = "仿宋" '字体
.Font.Bold = True '加粗
.Font.Size = 16 '字号，14=四号；16=三号……
.ParagraphFormat.Alignment = wdAlignParagraphCenter '居中对齐
.ParagraphFormat.OutlineLevel = wdOutlineLevel1 '设为标题1
End With
ElseIf apar.Range.Find.Execute(FindText:="第[一二三四五六七八九十]{1,}节 ", Forward:=True, MatchWildcards:=True) = True And InStr(MyStr, ActiveDocument.Range(apar.Range.Start, apar.Range.Start + 1).Text) > 0 Then
With apar.Range
.Font.Name = "等线（中文正文）" '字体
.Font.Bold = True '加粗
.Font.Size = 12 '字号，14=四号；16=三号……
.ParagraphFormat.Alignment = wdAlignParagraphCenter '居中对齐
.ParagraphFormat.OutlineLevel = wdOutlineLevel2 '设为标题1
End With
ElseIf apar.Range.Find.Execute(FindText:="[一二三四五六七八九十]{1,}、", Forward:=True, MatchWildcards:=True) = True And InStr(YouStr, ActiveDocument.Range(apar.Range.Start, apar.Range.Start + 1).Text) > 0 Then
With apar.Range
.Font.Name = "等线（中文正文）" '字体
.Font.Bold = True '加粗
.Font.Size = 10.5 '字号，14=四号；16=三号……
.ParagraphFormat.Alignment = wdAlignParagraphLeft '居中对齐
.ParagraphFormat.OutlineLevel = wdOutlineLevel3 '设为标题1
End With
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'删除重复标题
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
acon.Add apar.Range, VBA.CStr(apar.Range.Text)
If Err.Number = 457 Then
apar.Range.Delete '直接删除重复段落
'apar.Range.Font.Color = wdColorRed '标记重复段落为红色
Err.Clear
End If
End If
Next
End With
Application.ScreenUpdating = True
endtime = Timer
MsgBox "用时： " & endtime - startime
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2017-10-18 12:04
