Word宏代码集锦

Word宏代码集锦
Word宏代码集锦 (1)
一、修改word格式： (1)
1、' 智能清除选区软回车（换行符） (1)
2、' 清除选区多余空段 (1)
3、' 合并选区中“，”结束的多余分段 (3)
4、' 清除选区单字节空格 (3)
5、' 清除选区单字节空格 (4)
6、' 清除选区1字空格 (4)
7、' 清除选区段首2字空格 (4)
8、' 清除选区Tab (5)
9、' 增加选区空格 (5)
10、' 选区段首缩进0字 (5)
11、' 选区段首缩进:2字 (6)
12、' 选区段首缩进转空格—已完美 (6)
13、' 选区段后间距1行 (7)
14、' 选区段后间距1行 (7)
15、' 选区段后间距1行 (7)
16、' 清除选区图片 (7)
17、' 选区硬回车转软回车 (8)
18、' 清除选区软回车 (8)
19' 合并选区段落 (8)
20、' 选区空格转硬回车 (9)
21、' 选区标点半角转全角 (9)
22、' 选区标点全角转半角 (11)
23、' 选区中文句号转半角 (12)
24、’把文档第一段设置为标题1的格式 (12)
25、选中的文本横向居中 (12)
26、缩小字距 (13)
27、增大字距 (13)
28、缩小行距 (14)
29、增大行距 (14)
30、等高变宽 (15)
31、等高变窄 (15)
32、字表间距 (15)
33、纵向16开 (16)
34、插入页码 (16)
35、小写金额转大写金额 (17)
二、其它 (22)
1.调整图片大小 (22)
2.转字体 (23)
3.转文件格式 (25)
4、文件加密 (26)
5、字符替换 (27)
6、替换引号 (27)
7、打印为PDF格式文件 (28)
8、朗读文本 (28)
9. 文献标号上标化 (29)
10. 箭头上方加文字 (29)
11 添加参考文献格式一，参考文献在文档末尾以1．2．3．格式排列 (30)
12. 添加参考文献格式二，参考文献在文档末尾以[1] [2] [3] 格式排列，修改自格式一的代码 (30)
13. 返回正文 (31)
14. 再次引用已有参考文献 (31)
15. 查找被删参考文献遗留引用， (32)
16、统计修订的字数 (32)
17、快速提取脚注内容 (33)
18、从任意页面编排页码 (33)
19、批量实现缩放打印 (34)
20、对文档内容进行顺序排列 (35)
21、替换Word文档插图的超链接 (35)
22、为文档的每页添加固定内容 (36)
23、批量实现图片的等比例缩 (36)
一、修改word格式：
1、' 智能清除选区软回车（换行符）
Sub 智能清除选区软回车()
With Selection.Find
.Text = "?^l"
.Replacement.Text = "^&^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^1^l"
.Replacement.Text = "^&^p"
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^l"
.Replacement.Text = ""
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
2、' 清除选区多余空段
Sub 清除选区多余空段()
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p "
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
3、' 合并选区中“，”结束的多余分段
Sub 合并选区多余分段()
With Selection.Find
.Text = "，^p"
.Replacement.Text = "，"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "、^p"
.Replacement.Text = "、"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
4、' 清除选区单字节空格
Sub 清除选区单字节空格()
With Selection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
5、' 清除选区单字节空格
Sub 清除选区2单字节空格()
With Selection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
6、' 清除选区1字空格
Sub 清除选区1字空格()
With Selection.Find
.Text = ""
.Replacement.Text = ""
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
7、' 清除选区段首2字空格
Sub 清除选区段首2字空格()
With Selection.Find
.Text = ""
.Replacement.Text = ""
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
8、' 清除选区Tab
Sub 清除选区Tab()
With Selection.Find
.Text = vbTab
.Replacement.Text = ""
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
9、' 增加选区空格
Sub 增加选区空格()
With Selection.Find
.Text = ""
.Replacement.Text = ""
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
10、' 选区段首缩进0字
Sub 选区段首无缩进()
With Selection.Find
.Text = ""
.Replacement.Text = ""
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0) '左缩进0字符
.RightIndent = CentimetersToPoints(0) '右缩进0字符
.FirstLineIndent = CentimetersToPoints(0) '首行缩进点0公分
.CharacterUnitLeftIndent = 0 '左缩进单位0字符
.CharacterUnitRightIndent = 0 '右缩进单位0字符
.CharacterUnitFirstLineIndent = 0
End With
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0) '左缩进1字符
.RightIndent = CentimetersToPoints(0) '右缩进2字符
.FirstLineIndent = CentimetersToPoints(0) '首行缩进点0.35公分
.CharacterUnitLeftIndent = 0 '左缩进单位0字符
.CharacterUnitRightIndent = 0 '右缩进单位0字符
.CharacterUnitFirstLineIndent = 0
End With
End Sub
11、' 选区段首缩进:2字
Sub 选区段首缩进2字()
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0) '左缩进1字符
.RightIndent = CentimetersToPoints(0) '右缩进2字符
.FirstLineIndent = CentimetersToPoints(0.35) '首行缩进点单位公分
.CharacterUnitLeftIndent = 0 '左缩进单位0字符
.CharacterUnitRightIndent = 0 '右缩进单位0字符
.CharacterUnitFirstLineIndent = 2
End With
End Sub
12、' 选区段首缩进转空格—已完美
Sub 选区段首缩进转空格()
Selection.InsertParagraphBefore
Call 选区段首无缩进
With Selection.Find
.Text = "^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Delete
With Selection.Find
.Text = "^p"
.Replacement.Text = ""
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
13、' 选区段后间距1行
Sub 选区段后间距1行()
Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0) Selection.ParagraphFormat.LineUnitAfter = 1
End Sub
14、' 选区段后间距1行
Sub 选区段前段后间距半行()
Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0) Selection.ParagraphFormat.LineUnitBefore = 0.5
Selection.ParagraphFormat.LineUnitAfter = 0.5
End Sub
15、' 选区段后间距1行
Sub 选区段前段后无间距()
Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0) Selection.ParagraphFormat.LineUnitBefore = 0
Selection.ParagraphFormat.LineUnitAfter = 0
End Sub
16、' 清除选区图片
Sub 清除选区图片()
With Selection.Find
.Text = "^1"
.Replacement.Text = ""
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
17、' 选区硬回车转软回车
Sub 选区硬回车转软回车()
With Selection.Find
.Text = "^p"
.Replacement.Text = "^l"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
18、' 清除选区软回车
Sub 清除选区软回车()
' With Selection.Find
.Text = "^l"
.Replacement.Text = ""
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
19' 合并选区段落
Sub 合并选区段落()
With Selection.Find
.Text = ""
.Replacement.Text = ""
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p"
.Replacement.Text = "^l"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^l"
.Replacement.Text = ""
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll Selection.Paragraphs.Add '添加段落符号End Sub
20、' 选区空格转硬回车
Sub 选区空格转硬回车()
With Selection.Find
.Text = ""
.Replacement.Text = "^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
21、' 选区标点半角转全角
Sub 选区标点半角转全角()
With Selection.Find
.Text = ","
.Replacement.Text = "，"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = ";"
.Replacement.Text = "；"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = ":"
.Replacement.Text = "："
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "?"
.Replacement.Text = "？"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "!"
.Replacement.Text = "！"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "......"
.Replacement.Text = "……"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "."
.Replacement.Text = "。

"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
22、' 选区标点全角转半角
Sub 选区标点全角转半角()
With Selection.Find
.Text = "，"
.Replacement.Text = ","
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "；"
.Replacement.Text = ";"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "："
.Replacement.Text = ":"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "？"
.Replacement.Text = "?"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "！"
.Replacement.Text = "!"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "……"
.Replacement.Text = "......"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "。

"
.Replacement.Text = "."
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
23、' 选区中文句号转半角
Sub 选区中文句号转半角()
With Selection.Find
.Text = "。

"
.Replacement.Text = "."
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
24、’把文档第一段设置为标题1的格式
Sub 标题1()
ActiveDocument.Paragraphs(1).Style = ActiveDocument.Styles("标题1") Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End Sub
25、选中的文本横向居中
Sub 横向居中()
With Selection.Find
.Text = ""
.Replacement.Text = ""
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0) '左缩进0字符
.RightIndent = CentimetersToPoints(0) '右缩进0字符
.FirstLineIndent = CentimetersToPoints(0) '首行缩进点0公分
.CharacterUnitLeftIndent = 0 '左缩进单位0字符
.CharacterUnitRightIndent = 0 '右缩进单位0字符
.CharacterUnitFirstLineIndent = 0
End With
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0) '左缩进1字符
.RightIndent = CentimetersToPoints(0) '右缩进2字符
.FirstLineIndent = CentimetersToPoints(0) '首行缩进点0.35公分
.CharacterUnitLeftIndent = 0 '左缩进单位0字符
.CharacterUnitRightIndent = 0 '右缩进单位0字符
.CharacterUnitFirstLineIndent = 0
End With
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End Sub
26、缩小字距
Sub 缩小字距()
Dim b
On Error Resume Next
patibility(wdSpacingInWholePoints) = False '不按点阵缩放字距
If Selection.Font.Spacing = 9999999 Then '当字距不等时,此值为9999999 For b = 1 To Selection.Characters.Count '得到所选字符总数
Selection.Characters(b).Font.Spacing = Selection.Characters(b).Font.Spacing - 0.1 '为每个字符更改字距
Next b
Else
Selection.Font.Spacing = Selection.Font.Spacing - 0.1
End If
End Sub
27、增大字距
Sub 增大字距()
On Error Resume Next
patibility(wdSpacingInWholePoints) = False '不按点阵缩放字距
Dim b
If Selection.Font.Spacing = 9999999 Then '当字距不等时,此值为9999999 For b = 1 To Selection.Characters.Count '得到所选字符总数
Selection.Characters(b).Font.Spacing = Selection.Characters(b).Font.Spacing + 0.1 '为每个字符更改字距
Next b
Else
Selection.Font.Spacing = Selection.Font.Spacing + 0.1
End If
End Sub
28、缩小行距
Sub 缩小行距()
Dim b
On Error Resume Next
StatusBar = "老刘郑重提示: 该命令会取消行自动对齐到行网格！"
With Selection.ParagraphFormat
.AutoAdjustRightIndent = False '不自动调整右缩进
.DisableLineHeightGrid = True '不自动对齐行网格
End With
If Selection.ParagraphFormat.LineSpacing = 9999999 Then
For b = 1 To Selection.Paragraphs.Count
Selection.Paragraphs(b).LineSpacing = Selection.Paragraphs(b).LineSpacing * 0.95
Next b
Else
Selection.ParagraphFormat.LineSpacing = Selection.ParagraphFormat.LineSpacing * 0.95
End If
End Sub
29、增大行距
Sub 增大行距()
Dim b
On Error Resume Next
StatusBar = "老刘郑重提示: 该命令会取消行自动对齐到行网格！"
With Selection.ParagraphFormat
.AutoAdjustRightIndent = False '不自动调整右缩进
.DisableLineHeightGrid = True '不自动对齐行网格
End With
If Selection.ParagraphFormat.LineSpacing = 9999999 Then '当段落间距不等时,此值为9999999
For b = 1 To Selection.Paragraphs.Count '得到所选段落总数Selection.Paragraphs(b).LineSpacing = Selection.Paragraphs(b).LineSpacing * 1.05
Next b
Else
Selection.ParagraphFormat.LineSpacing = Selection.ParagraphFormat.LineSpacing * 1.05
End If
End Sub
30、等高变宽
Sub 等高变宽()
On Error Resume Next
Selection.Font.Scaling = Selection.Font.Scaling + 1
End Sub
31、等高变窄
Sub 等高变窄()
On Error Resume Next
Selection.Font.Scaling = Selection.Font.Scaling - 1
End Sub
32、字表间距
Sub 字表间距()
On Error Resume Next
patibility(wdAlignTablesRowByRow) = False
Selection.Tables(1).Select
With Selection.Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End With
On Error GoTo a:
Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
Selection.Rows.SpaceBetweenColumns = 0
Selection.Tables(1).AllowAutoFit = False
a:
If Err = 4605 Then
MsgBox "当前位置不在表格中,请重新定义。

", vbInformation, "刘厚彬现在轻轻地告诉你"
End If
End Sub
33、纵向16开
Sub 纵向16开()
' With ActiveDocument.Range(Start:=Selection.Start, End:=ActiveDocument. _ Content.End).PageSetup '插入点之后
'With ActiveDocument.PageSetup '整篇文档
With Selection.PageSetup '本节
.Orientation = wdOrientPortrait '纵向
.TopMargin = MillimetersToPoints(24)
.BottomMargin = MillimetersToPoints(25)
.LeftMargin = MillimetersToPoints(28)
.RightMargin = MillimetersToPoints(25)
.FooterDistance = MillimetersToPoints(21)
.PageWidth = MillimetersToPoints(196)
.PageHeight = MillimetersToPoints(270)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
End With
End Sub
34、插入页码
Sub 插入页码()
Dim fstpg As Byte
Dim mydialog As Dialog
Dim a As String
On Error Resume Next
fstpg = 1
ActiveWindow.View.ShowFieldCodes = False '隐藏窗口域代码
Set mydialog = Dialogs(wdDialogInsertPageNumbers)
If mydialog.Display = -1 Then '-2关闭；-1确定；0取消；1第一个按钮，2第二个按钮，以此类推。

If mydialog.firstpage = False Then '判断首页是否打印页码
mydialog.firstpage = True
fstpg = False
End If
mydialog.Execute
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter '切换到页脚Selection.SetRange Start:=0, End:=4 '选定前3个字符文本
If VBA.Mid$(Selection.text, 1, 1) <> "—" Then
Selection.EndKey Unit:=wdLine
Selection.TypeText text:=" —"
Selection.MoveLeft Unit:=wdCharacter, Count:=5
Selection.TypeText text:="— "
Selection.ParagraphFormat.CharacterUnitRightIndent = 0.75
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 1.19
End If
If fstpg = False Then
mydialog.firstpage = False
mydialog.Execute '首页不显示页码
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End If
End Sub
35、小写金额转大写金额
Sub 大写金额()
Dim BigNum, snum, i, mydata As DataObject
On Error GoTo e
Set mydata = New DataObject
BigNum = ""
snum = Selection.text
If IsNumeric(snum) = False Then
mydata.GetFromClipboard '从剪切板取值
snum = mydata.GetText(1)
End If
snum = VBA.Trim(VBA.str(Int(Round(snum, 2) * 100)))
If snum < 0 Then snum = -snum: BigNum = "负"
If snum = 0 Then
BigNum = "零元整"
Else
Const cNum = "零壹贰叁肆伍陆柒捌玖-万仟佰拾亿仟佰拾万仟佰拾元角分"
Const cCha = "零仟零佰零拾零零零零零亿零万零元亿万零角零分零整-零零零零零亿万元亿零整整"
For i = 1 To Len(snum) '逐位转换
BigNum = BigNum + VBA.Mid(cNum, (VBA.Mid(snum, i, 1)) + 1, 1) + VBA.Mid(cNum, 26 - Len(snum) + i, 1)
Next i
BigNum = Replace(BigNum, "零亿", "亿零")
BigNum = Replace(BigNum, "零万", "万零")
BigNum = Replace(BigNum, "零元", "元零")
For i = 0 To 11 '去掉多余的零
BigNum = Replace(BigNum, VBA.Mid(cCha, i * 2 + 1, 2), VBA.Mid(cCha, i + 26, 1)) Next i
End If
Selection.MoveRight
Selection.TypeText text:=BigNum
End
e:
MsgBox "你输入数字错误或太大!请重新输入。

", vbExclamation + vbOKOnly, "提示" End Sub
36、’去掉空白行
Sub 去掉空白行()
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "[^11^13]{2,}"
.Replacement.Text = "^13"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.GoBack
End Sub
37、查找替换
Sub 查找替换()
With ActiveDocument.Content.Find
.ClearFormatting '清除格式设置
= "新宋体" '查找的字体格式
With .Replacement '替换条件
.ClearFormatting '清除格式设置
= "黑体" '替换成黑体
End With
.Execute findtext:="", ReplaceWith:="", Format:=True, _
Replace:=wdReplaceAll '是格式替换,全部替换End With
End Sub
38、总结：word自动化排版宏
Sub 格式设置()
'
' 格式设置 Macro
Application.ScreenUpdating = False
'更改所有硬回车为软回车
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
'去除所有空行
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
'去除半角空格
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting With Selection.Find
.Text = " "
.Replacement.Text = ""
.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 '去除全角空格
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'替换非标准引号为标准引号
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = """(*)"""
.Replacement.Text = ChrW(8220) & "\1" & ChrW(8221)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'字母数字符号全角转半角 Macro
Dim qjsz, bjsz As String, iii As Integer '定义qjsz(全角数字)、bjsz(半角数字)为字符串型，iii 为整数型
qjsz = "０１２３４５６７８９ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ,./<>?;’:[]{}\|=-+_)(
bjsz = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXY Z，。

／《》？；'：【】｛｝＼｜＝－＋＿）（
Selection.WholeStory
For iii = 1 To 95 '循环10次
With Selection.Find
.Text = Mid(qjsz, iii, 1) 'mid函数：返回文本字符串中从指定位置开始的特定数目的字符，每次取一个数字
.Replacement.Text = Mid(bjsz, iii, 1) '将用于替换的相应位置的半角数字
.Format = False '保留替换前的字符格式
.MatchWildcards = False
.Execute Replace:=wdReplaceAll '用半角符号替换全角符号
End With
Next iii
'修改小数点错误
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([0-9])。

([0-9])"
.Replacement.Text = "\1.\2"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'设置字号
Selection.WholeStory '全选
Selection.ClearFormatting '清除全文格式
Selection.Font.Size = 14 '设置字号为14号
'设置行距
Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
Selection.ParagraphFormat.LineSpacing = 25
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify '设置文本为两端对齐
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 2 '设置段首缩进2字符
Selection.HomeKey Unit:=wdStory '移至文首
Selection.EndKey Unit:=wdLine, Extend:=wdExtend '选中首行
Selection.ClearFormatting '清除首行格式
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '设置首行居中对齐
Selection.ParagraphFormat.LineUnitBefore = 1 '设置首行段前间距1行
Selection.ParagraphFormat.LineUnitAfter = 1 '设置首行段后间距1行
= "微软雅黑" '设置首行字体为“微软雅黑”
Selection.Font.Size = 18 '设置首行字号为18号
Selection.Font.Bold = wdToggle '设置首行字形为加粗
Application.ScreenUpdating = True
End Sub
二、其它
1.调整图片大小
Sub setpicsize() '设置图片大小
Dim n '图片个数
On Error Resume Next '忽略错误
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes 类型图片
ActiveDocument.InlineShapes(n).Height = 400 '设置图片高度为400px
ActiveDocument.InlineShapes(n).Width = 300 '设置图片宽度300px
Next n
For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片ActiveDocument.Shapes(n).Height = 400 '设置图片高度为 400px ActiveDocument.Shapes(n).Width = 300 '设置图片宽度 300px Next n
End Sub
2.转字体
Sub 批量设置小5号字体() '此代码为指定文件夹中所有选取的WORD 文件的进行格式设置
Dim MyDialog As FileDialog, vrtSelectedItem As Variant, Doc As Document
' On Error Resume Next '忽略错误
'定义一个文件夹选取对话框
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Title = "请选择要处理的文档（可多选）"
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add "所有 WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择
If .Show = -1 Then '确定
Application.ScreenUpdating = False
For Each vrtSelectedItem In .SelectedItems '在所有选取项目中循环
Set Doc = Documents.Open(FileName:=vrtSelectedItem, Visible:=False)
With Doc
With .Content
With .Font
' .NameFarEast = "宋体" '中文字体，已禁用
' .NameAscii = "Times New Roman" '英文字体，已禁用
.Size = 9
End With
End With
.Close True
End With
Next
Application.ScreenUpdating = True
End If
End With
MsgBox "批量设置完毕!", vbInformation
End Sub
3.转文件格式
Sub Macro1()
' Macro1 Macro
' 宏在 01-10-31录制
'
Dim name As String '文件名
name = "01"
ChangeFileOpenDirectory "E:\VB_SOUCE\lib\"
For i = 1 To 2124 '文件数2124
Documents.Open filename:=name & ".txt", ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto
ActiveDocument.SaveAs filename:=name & ".txt", FileFormat:= _
wdFormatTextLineBreaks, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False
ActiveWindow.Close
name = name + 1
If name < 10 Then name = "0" & name
Next i
End Sub
4、文件加密
sub mima（）
with activedocument
.password="123"
.writepassword="456"
end with
end sub
‘要注意的方面：第三行是打开权限、第四行是修改权限。

5、字符替换
Sub 字符替换() '宏名称，可修改为其他字符
With ActiveDocument.Content.Find '在当前文档中进行查找
.Text = "其它" '被替换的字符
.Replacement.Text = "其他" '替换的字符
.Execute Replace:=wdReplaceAll, Forward:=True '替换全部End With
End Sub
6、替换引号
Sub 替换引号()
Dim Countx As Integer, i As Integer, Sh As Byte '声明变量
'以下代码统计出文中的引号数目(包括""“”)
Countx = 0
On Error Resume Next
With ActiveDocument.Content.Find
Do While .Execute(FindText:="""", Forward:=True, Format:=True) = True
Countx = Countx + 1
Loop
'以下代码判断引号是否配对出现
Sh = Countx Mod 2
If Sh <> 0 Then
MsgBox "引号不配对！"
Exit Sub '如果引号不配对，则退出宏
End If
End With
For i = 1 To Countx
Sh = i Mod 2 '求i值除以2的余数
If Sh <> 0 Then '如果余数不等于0(即为奇数)，则将相应的引号替'换为“前z”With ActiveDocument.Content.Find
.Text = """"
.Replacement.Text = "前z"
.Execute Replace:=wdReplaceOne, Forward:=True。