|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
这是我在网上找的代码，几个凑在一起的其中的
Sub 第二行插入空行()
'若当前文档第二段段尾带中文标点__则段前加一空行
Dim myRange As Range
Set myRange = ActiveDocument.Range(Start:=ActiveDocument.Paragraphs(2).Range.End - 2, _
End:=ActiveDocument.Paragraphs(2).Range.End - 1)
If Len(ActiveDocument.Paragraphs(2).Range) > 1 And _
myRange.Text Like "[，。！：？…。’”〉》—]" Then
ActiveDocument.Paragraphs(2).Range.InsertBefore Chr(13)
End If
End Sub
这段代码不能运行，求修改，我还想把段首的空格去掉，自己录制的宏加进来也不能用，求指点。
下面这是代码：
Sub 批量设置Word格式()
Down = MsgBox("下面将要对文件进行格式化！" & vbCrLf & "（所有文件统一格式）" & vbCrLf & vbCrLf & _
"你真的要排版吗？？？？", vbQuestion + vbYesNo, "★☆ 排版时请注意 ☆★")
If Down = vbNo Then
Exit Sub
End If '选择"是"，执行下列操作
Application.ScreenUpdating = False '冻结屏幕，以防屏幕抖动，这句好像没作用，窗口仍然会颤抖
Dim mydialog As FileDialog, GetStr(1 To 40) As String '40是工作时的文档上限数，可因需修改，不知没有限制的命令怎样写？
On Error Resume Next
Set mydialog = Application.FileDialog(msoFileDialogFilePicker)
With mydialog
.Title = "请选择要处理的文档(可多选)"
.Filters.Clear
.Filters.Add "所有WORD文件", "*.doc", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
Call 去除所有空行
Call 更改硬回车
Call 页边距
Call 第二行插入空行
Call 设置段落
Call 设置大小标题
Call 给以一二三开头的小标题加粗
'以上为宏操作部分，可以自行录制
' C公共部分的代码
myDoc.Save
myDoc.Close
Set myDoc = Nothing
Next
End With
Application.ScreenUpdating = True
MsgBox "批量排版完毕!请查看！！", vbInformation
End Sub
Sub 页边距()
'页边距
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(2.5) '上边距
.BottomMargin = CentimetersToPoints(2.5) '下边距
.LeftMargin = CentimetersToPoints(3.1) '左边距
.RightMargin = CentimetersToPoints(3.1) '右边距
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.5)
.FooterDistance = CentimetersToPoints(1.75)
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
.LayoutMode = wdLayoutModeLineGrid
End With
End Sub
Sub 第二行插入空行()
'若当前文档第二段段尾带中文标点__则段前加一空行
Dim myRange As Range
Set myRange = ActiveDocument.Range(Start:=ActiveDocument.Paragraphs(2).Range.End - 2, _
End:=ActiveDocument.Paragraphs(2).Range.End - 1)
If Len(ActiveDocument.Paragraphs(2).Range) > 1 And _
myRange.Text Like "[，。！：？…。’”〉》—]" Then
ActiveDocument.Paragraphs(2).Range.InsertBefore Chr(13)
End If
End Sub
Sub 更改硬回车()
'更改所有硬回车为软回车
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^l"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub 去除所有空行()
Dim i As Paragraph, n As Integer
Application.ScreenUpdating = False
For Each i In ActiveDocument.Paragraphs
If Len(i.Range) = 1 Then
i.Range.Delete
n = n + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Sub 设置段落()
' 段落
Set arange = ActiveDocument.Range( _
Start:=ActiveDocument.Paragraphs(2).Range.Next(wdParagraph).Start, _
End:=ActiveDocument.Content.End - 1)
arange.Select
Selection.ClearFormatting
Selection.ClearFormatting
Selection.Font.Size = 14 '正文字号
Selection.Font.Name = "仿宋体" '正文字体
With Selection.ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceExactly
.LineSpacing = 26 '固定行距28
.FirstLineIndent = CentimetersToPoints(0)
.CharacterUnitFirstLineIndent = 2 '行首缩进2个字符
.WordWrap = True
End With
End Sub
Sub 设置大小标题()
'大标题
ActiveDocument.Paragraphs(1).Range.Select
Selection.ClearFormatting
Selection.ClearFormatting
Selection.Font.Bold = wdToggle
Selection.Font.Name = "方正小标宋简体"
Selection.Font.Size = 22
Selection.Font.Bold = wdToggle
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
'小标题
ActiveDocument.Paragraphs(2).Range.Select
Selection.ClearFormatting
Selection.ClearFormatting
Selection.Font.Size = 14
Selection.Font.Name = "仿宋体" '正文字体
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End Sub
Sub 给以一二三开头的小标题加粗()
Dim i As Integer '循环执行
For i = 1 To 20 '假设有20个，循环执行20次
' 查找一二三……十加顿号开头的段落，下面为查找过程录制宏
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([一二三四五六七八九十]{1,}、)(*^13)"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
' 上面为查找过程录制宏
' 下面为字体设置录制宏
Selection.Find.Execute ' 设置字体字号 Macro
Selection.Font.Name = "黑体" '字体
Selection.ClearFormatting
Selection.ClearFormatting
Selection.Font.Bold = wdToggle '加粗
Selection.Font.Size = 14 '字号，14=四号；16=三号……
' 上面为字体设置录制宏
With Selection.ParagraphFormat
.CharacterUnitFirstLineIndent = 2 '行首缩进2个字符
.WordWrap = True
End With
Next i
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2014-7-17 21:27
