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
https://www.doczj.com/doc/ff8050934.html,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
https://www.doczj.com/doc/ff8050934.html,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
https://www.doczj.com/doc/ff8050934.html,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