1. 修改word格式1.1 智能清除选区软回车（换行符）1.2. 清除选区多余空段1.3. 合并选区中“，”结束的多余分段1.4. 清除选区单字节空格1.5. 清除选区单字节空格1.6. 清除选区1字空格1.7. 清除选区段首2字空格1.8. 清除选区Tab1.9. 增加选区空格1.10. 选区段首缩进0字1.11. 选区段首缩进:2字1.12. 选区段首缩进转空格—已完美1.13. 选区段后间距1行1.14. 选区段前段后间距半行1.15. 选区段前段后无间距1.16. 清除选区图片1.17. 选区硬回车转软回车1.18. 清除选区软回车1.19. 合并选区段落1.20. 选区空格转硬回车1.21. 选区标点半角转全角1.22. 选区标点全角转半角1.23. 选区中文句号转半角1.24. 把文档第一段设置为标题1的格式1.25. 选中的文本横向居中1.26. 缩小字距1.27. 增大字距1.28. 缩小行距1.29. 增大行距1.30. 等高变宽1.31. 等高变窄1.32. 字表间距1.33. 纵向16开1.34. 插入页码1.35. 小写金额转大写金额1.36. 去掉空白行1.37. 查找替换1.38. 格式设置 Macro2. 其它2.1. 调整图片大小2.2. 转字体2.3. 转文件格式2.4. 文件加密2.5. 字符替换2.6. 替换引号2.7. 打印为PDF格式文件2.8. 朗读文本2.9. 文献标号上标化2.10. 箭头上方加文字2.11. 添加参考文献格式一，参考文献在文档末尾以1． 2． 3．格式排列2.12. 添加参考文献格式二，参考文献在文档末尾以[1] [2] [3] 格式排列，修改自格式一的代码2.13. 返回正文2.14. 再次引用已有参考文献2.15. 查找被删参考文献遗留引用2.16. 统计修订的字数2.17. 快速提取脚注内容2.18. 从任意页面编排页码2.19. 批量实现缩放打印1.20. 对文档内容进行顺序排列1.21. 替换Word文档插图的超链接1.22. 为文档的每页添加固定内容1.23. 批量实现图片的等比例缩1.24. 提取域代码1.25. 完美显示图片表格的普通视图1.26. 完美显示图片表格的页面视图1.27. 彻底删除页眉页脚1.28. 切换纵横向页面
1. 修改word格式
1.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:=wdReplaceAllEnd Sub
1.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:=wdReplaceAllEnd Sub
1.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:=wdReplaceAllEnd Sub
1.4. 清除选区单字节空格Sub 清除选区单字节空格() With Selection.Find .Text = " " .Replacement.Text = "" .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.5. 清除选区单字节空格Sub 清除选区2单字节空格() With Selection.Find .Text = " " .Replacement.Text = "" .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.6. 清除选区1字空格Sub 清除选区1字空格() With Selection.Find .Text = " " .Replacement.Text = "" .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.7. 清除选区段首2字空格Sub 清除选区段首2字空格() With Selection.Find .Text = " " .Replacement.Text = "" .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.8. 清除选区TabSub 清除选区Tab() With Selection.Find .Text = vbTab .Replacement.Text = "" .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.9. 增加选区空格Sub 增加选区空格() With Selection.Find .Text = " " .Replacement.Text = " " .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.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 WithEnd Sub
1.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 WithEnd Sub
1.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:=wdReplaceAllEnd Sub
1.13. 选区段后间距1行Sub 选区段后间距1行() Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0) Selection.ParagraphFormat.LineUnitAfter = 1End Sub
1.14. 选区段前段后间距半行Sub 选区段前段后间距半行() Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0) Selection.ParagraphFormat.LineUnitBefore = 0.5 Selection.ParagraphFormat.LineUnitAfter = 0.5End Sub
1.15. 选区段前段后无间距Sub 选区段前段后无间距() Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0) Selection.ParagraphFormat.LineUnitBefore = 0 Selection.ParagraphFormat.LineUnitAfter = 0End Sub
1.16. 清除选区图片Sub 清除选区图片() With Selection.Find .Text = "^1" .Replacement.Text = "" .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.17. 选区硬回车转软回车Sub 选区硬回车转软回车() With Selection.Find .Text = "^p" .Replacement.Text = "^l" .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.18. 清除选区软回车Sub 清除选区软回车()' With Selection.Find .Text = "^l" .Replacement.Text = "" .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.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
1.20. 选区空格转硬回车Sub 选区空格转硬回车() With Selection.Find .Text = " " .Replacement.Text = "^p" .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.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:=wdReplaceAllEnd Sub
1.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:=wdReplaceAllEnd Sub
1.23. 选区中文句号转半角Sub 选区中文句号转半角() With Selection.Find .Text = "。" .Replacement.Text = "." .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAllEnd Sub
1.24. 把文档第一段设置为标题1的格式Sub 标题1() ActiveDocument.Paragraphs(1).Style = ActiveDocument.Styles("标题 1") Selection.ParagraphFormat.Alignment = wdAlignParagraphCenterEnd Sub
1.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 = wdAlignParagraphCenterEnd Sub
1.26. 缩小字距Sub 缩小字距() Dim b On Error Resume Next ActiveDocument.Compatibility(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 IfEnd Sub
1.27. 增大字距Sub 增大字距() On Error Resume Next ActiveDocument.Compatibility(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 IfEnd Sub
1.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 IfEnd Sub
1.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 IfEnd Sub
1.30. 等高变宽Sub 等高变宽() On Error Resume Next Selection.Font.Scaling = Selection.Font.Scaling + 1End Sub
1.31. 等高变窄Sub 等高变窄() On Error Resume Next Selection.Font.Scaling = Selection.Font.Scaling - 1End Sub
1.32. 字表间距Sub 字表间距() On Error Resume Next ActiveDocument.Compatibility(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 = Falsea: If Err = 4605 Then MsgBox "当前位置不在表格中,请重新定义。", vbInformation, "刘厚彬现在轻轻地告诉你" End IfEnd Sub
1.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 = wdPrinterDefaultBinEnd WithEnd Sub
1.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 IfEnd Sub
1.35. 小写金额转大写金额Sub 大写金额()Dim BigNum, snum, i, mydata As DataObjectOn Error GoTo eSet mydata = New DataObjectBigNum = ""snum = Selection.textIf IsNumeric(snum) = False Then mydata.GetFromClipboard '从剪切板取值 snum = mydata.GetText(1)End Ifsnum = 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 Ende: MsgBox "你输入数字错误或太大!请重新输入。", vbExclamation + vbOKOnly, "提示"End Sub
1.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.GoBackEnd Sub
1.37. 查找替换Sub 查找替换() With ActiveDocument.Content.Find .ClearFormatting '清除格式设置 .Font.Name = "新宋体" '查找的字体格式 With .Replacement '替换条件 .ClearFormatting '清除格式设置 .Font.Name = "黑体" '替换成黑体 End With .Execute findtext:="", ReplaceWith:="", Format:=True, _ Replace:=wdReplaceAll '是格式替换,全部替换 End WithEnd Sub
1.38. 格式设置 MacroSub 格式设置() ' ' 格式设置 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 Selection.Find.Execute Replace:=wdReplaceAll '去除所有空行 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.Execute Replace:=wdReplaceAll '替换非标准引号为标准引号 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 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ，。／《》？；'：【】｛｝＼｜＝－＋＿）（ 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.Name = "微软雅黑" '设置首行字体为“微软雅黑” Selection.Font.Size = 18 '设置首行字号为18号 Selection.Font.Bold = wdToggle '设置首行字形为加粗 Application.ScreenUpdating = True End Sub
2. 其它
2.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.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
2.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
2.4. 文件加密 sub mima（）
with activedocument
.password="123"
.writepassword="456"
end with
end sub
‘要注意的方面：第三行是打开权限、第四行是修改权限。
2.5. 字符替换Sub 字符替换() '宏名称，可修改为其他字符
With ActiveDocument.Content.Find '在当前文档中进行查找
.Text = "其它" '被替换的字符
.Replacement.Text = "其他" '替换的字符
.Execute Replace:=wdReplaceAll, Forward:=True '替换全部
End With
End Sub
2.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
End With
Else
With ActiveDocument.Content.Find '反之则将相应的引号替换为“后z”
.Text = """"
.Replacement.Text = "后z"
.Execute Replace:=wdReplaceOne, Forward:=True
End With
End If
Next '进行下一对引号的替换
With ActiveDocument.Content.Find
'以下代码将所有的“前z”替换为左引号
.Text = "前z"
.Replacement.Text = "“"
.Execute Replace:=wdReplaceAll, Forward:=True
'以下代码将所有的“后z”替换为右引号
.Text = "后z"
.Replacement.Text = "”"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
End Sub
2.7. 打印为PDF格式文件Sub 打印为PDF格式文件()
On Error GoTo c:
Dim a As Balloon
Dim b As String
b = ActivePrinter
Options.PrintDrawingObjects = True '打印图形对象
ActivePrinter = "Acrobat PDFWriter"
ActiveDocument.PrintOut
c:
ActivePrinter = b
End Sub
2.8. 朗读文本Sub 朗读文本()
On Error Resume Next
StatusBar = "老刘郑重提示: 执行该命令后文本如果未朗读完将不能进行其他操作！"
Excel.Application.Speech.Speak (ActiveWindow.Selection)
End Sub
2.9. 文献标号上标化Sub 文献标号上标化()
'
' 参考文献上标化 Macro
' 宏在 2006-11-3 由 ***** 创建
'
Selection.HomeKey Unit:=wdStory
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.Font
.Superscript = True
End With
With Selection.Find
.Text = "\[[０-９，0-9,～~－\-\ ]@\]"
.Replacement.Text = ""
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.Font
.Superscript = True
End With
With Selection.Find
.Text = "［[０-９，0-9,～~－\-\ ]@］"
.Replacement.Text = ""
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
2.10. 箭头上方加文字Sub 箭头上方加文字()
'
' 箭头上方加文字 Macro
' 宏在 2008-4-16 由 ***** 创建
'
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
PreserveFormatting:=False
Selection.TypeBackspace
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="eq \o(\s\do2(──────────→),\s\up5(敲击Delete键清除此段文字，改填所需文字，酌情增减箭头长度，最后同时按下shift和F9))"
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdWord, Count:=25, Extend:=wdExtend ‘顾经宇的代码是26，改成25更好
End Sub
2.11. 添加参考文献格式一，参考文献在文档末尾以1． 2． 3．格式排列Sub 添加参考文献格式一()
'
' 添加参考文献 Macro
' 宏在 2008-4-17 由 ***** 创建
'
Selection.Style = ActiveDocument.Styles("尾注引用")
Selection.TypeText Text:="[]"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With ActiveDocument.Endnotes
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
End With
ActiveDocument.Endnotes.Add Range:=Selection.Range, Reference:=""
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("默认段落字体")
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="． "
End Sub
2.12. 添加参考文献格式二，参考文献在文档末尾以[1] [2] [3] 格式排列，修改自格式一的代码Sub 添加参考文献格式二()
'
' 添加参考文献 Macro
' 宏在 2021-4-17 由 ***** 创建
'
Selection.Style = ActiveDocument.Styles("尾注引用")
Selection.TypeText Text:="[]"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With ActiveDocument.Endnotes
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
End With
ActiveDocument.Endnotes.Add Range:=Selection.Range, Reference:=""
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("默认段落字体")
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="] "
Selection.MoveLeft Unit:=wdCharacter + 2, Count:=1
Selection.TypeText Text:="["
End Sub
2.13. 返回正文Sub 返回正文()
'返回正文 Macro
'宏在 2008-4-16 由 ***** 创建
'
If ActiveWindow.ActivePane.View.Type = wdPageView Or ActiveWindow. _
ActivePane.View.Type = wdOnlineView Or ActiveWindow.ActivePane.View.Type _
= wdPrintPreview Then
ActiveWindow.View.SeekView = wdSeekMainDocument
Else
ActiveWindow.Panes(2).Close
End If
Selection.MoveRight Unit:=wdCharacter, Count:=2
End Sub
2.14. 再次引用已有参考文献Sub 引用编号()
'引用编号 Macro
'宏在 2008-4-16 由 ***** 创建
'
Selection.Font.Superscript = wdToggle
Selection.TypeText Text:="[]"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With Dialogs(wdDialogInsertCrossReference)
.InsertAsHyperlink = True
.Show
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Font.Superscript = wdToggle
End Sub
2.15. 查找被删参考文献遗留引用Sub 查找被删编号()
'要删除某个参考文献，应该在原始引用处删除引用，这样可以一并删除参考文献，而不是在文档末尾文献列表处删除
Selection.WholeStory
Selection.Fields.Update
Selection.Find.ClearFormatting
With Selection.Find
.Text = "错误！未定义书签。"
End With
Selection.Find.Execute
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
End Sub
2.16. 统计修订的字数Sub test()
Dim Rev As Revision, c1 As Long, n1 As Integer, a As String
Dim Wd As Range, c2 As Long, n2 As Integer, b As String
For Each Rev In ActiveDocument.Revisions
If Rev.Type = wdRevisionInsert Then
For Each Wd In Rev.Range.Words
c1 = c1 + IIf(Wd Like "[一-龥]*", Wd.Characters.Count, 1)
Next
n1 = n1 + 1
a = a & Rev.Range.text & vbTab
ElseIf Rev.Type = wdRevisionDelete Then
For Each Wd In Rev.Range.Words
c2 = c2 + IIf(Wd Like "[一-龥]*", Wd.Characters.Count, 1)
Next
n2 = n2 + 1
b = b & Rev.Range.text & vbTab
End If
Next
MsgBox "增加内容" & n1 & "处共" & c1 & "字；删除内容" &
n2 & "处共" & c2 & "字。"
End Sub
2.17. 快速提取脚注内容Sub 快速提取脚注内容()
Dim oFootNote As Footnote, myRange As Range
Dim BeforeName As String, BeforeSize As Single
On Error Resume Next
Application.ScreenUpdating = False
For Each oFootNote In ActiveDocument.Footnotes
With oFootNote
Set myRange = ActiveDocument.Range(.Reference.Start, .Reference.End)
.Range.Copy
With myRange
.Text = "(JZ: )"
BeforeName = .Font.Name
BeforeSize = .Font.Size
myRange.SetRange .Start + 4, .Start + 4
.Paste
.Font.Name = BeforeName
.Font.Size = BeforeSize
End With
End With
Next
Application.ScreenUpdating = True
End Sub
2.18. 从任意页面编排页码Sub 从任意页面编排页码()
myPath = "H:\temp\"
Selection.HomeKey Unit:=wdStory
Set myRange = Selection.Range
curpage = 0
Application.ScreenUpdating = False
Do
prepage = curpage
pagenum = pagenum + 1
Set myRange = myRange.GoToNext(What:=wdGoToPage)
curpage = myRange.Start
endpage = myRange.Previous.Start
If curpage = prepage Then _
endpage = ActiveDocument.Content.End
ActiveDocument.Range(prepage, endpage).Copy
With Documents.Add
.Content.Paste
.SaveAs myPath & "Page" & pagenum & ".doc"
.Close
End With
If curpage = prepage Then Exit Do
Loop
Application.ScreenUpdating = True
End Sub
2.19. 批量实现缩放打印Sub 批量实现缩放打印()
Application.ScreenUpdating = False
With Application.FileSearch
.LookIn = "h:\Downloads\temp5\"
.FileType = msoFileTypeWordDocuments
If .Execute > 0 Then
Fori = 1To.FoundFiles.Count
Documents.Open FileName:=.FoundFiles(i)
ActiveDocument.PrintOutPrintZoomPaperWidth:=10433,
PrintZoomPaperHeight:=14742
ActiveDocument.Close False
Next i
End If
End With
Application.ScreenUpdating = True
End Sub
1.20. 对文档内容进行顺序排列Sub 对文档内容进行顺序排列()
Dim s() As String, temp As String, i As Long
VBAs = Split(ActiveDocument.Content, Chr(13) & Chr(13))
For i = 0 To UBound(s) \ 2
temp = s(i)
s(i) = s(UBound(s) - i)
s(UBound(s) - i) = temp
Next
Documents.Add
ActiveDocument.Content.Text = Join(s, Chr(13) & Chr(13))
End Sub
1.21. 替换Word文档插图的超链接Sub 替换Word文档插图的超链接()
n = 0
For Eachs In ActiveDocument.Shapes
s.Select
ActiveDocument.Hyperlinks.Add Anchor:=Selection.ShapeRange, _
Address:="http://www.sina.com"
n=n+1
Next
MsgBox "共替换" &n& "个图片！"
End Sub
1.22. 为文档的每页添加固定内容Sub 为文档的每页添加固定内容()
Dim m As Integer, n As Page
m = Selection.Information(wdNumberOfPagesInDocument)
Selection.HomeKey Unit:=wdStory
For o = 1 To m
With Selection
.TypeText Text:="机械制图国家标准"
.GoToNext what:=wdGoToPage
End With
Next
End Sub
1.23. 批量实现图片的等比例缩Sub 批量实现图片的等比例缩()
Dim Shp As Shape, InlineShp As InlineShape
Dim Bder As Border
With ActiveDocument
For Each Shp In .Shapes
Shp.LockAspectRatio = msoTrue
Shp.Width = 4 * 28.35
Next
For Each InlineShp In .InlineShapes
InlineShp.LockAspectRatio = msoTrue
InlineShp.Width = 4 * 28.35
For Each Bder In InlineShp.Borders
With Bder
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
Next
Next
End With
End Sub
'上述代码中的“LockAspectRatio = msoTrue”表示锁定纵横比，如果不需要锁定纵横比，那么可以修改为“LockAspectRatio = msoFalse”。
1.24. 提取域代码Sub 提取域代码()
Dim myRange As Range, myCodes As String
Set myRange = Selection.Range
With myRange
If .Fields.Count = 0 Then
MsgBox "您所选的内容中没有域代码!", vbInformation
Exit Sub
Else
.Fields.Update
.TextRetrievalMode.IncludeFieldCodes = True
.TextRetrievalMode.IncludeHiddenText = True
myCodes = .Text
myCodes = VBA.Replace(myCodes, Chr(19), "{")
myCodes = VBA.Replace(myCodes, Chr(21), "}")
.SetRange .End, .End
.InsertAfter myCodes '"注意,""{}""是由Ctrl+F9组合键自动插入的域标志! " & vbLf & "域代码:" & myCodes
.Font.Name = "Tahoma"
.Font.Size = 11
.Cut
End If
End With
End Sub
1.25. 完美显示图片表格的普通视图Sub 完美显示图片表格的普通视图()
'此宏为雨雪霏霏特别奉献的小偏方，欢迎各位朋友测试。
'如果文档中的嵌入式图片、表格显示迟滞、错位，运行此宏，将在普通视图下完美显示它们。
ActiveDocument.PrintPreview
ActiveDocument.ClosePrintPreview
ActiveWindow.View.Type = wdNormalView
End Sub
1.26. 完美显示图片表格的页面视图Sub 完美显示图片表格的页面视图()
'此宏为雨雪霏霏特别奉献的小偏方，欢迎各位朋友测试。
'如果文档中的各种图片、表格显示迟滞、错位，运行此宏，将在页面视图下完美显示它们。
ActiveDocument.PrintPreview
ActiveDocument.ClosePrintPreview
ActiveWindow.View.Type = wdNormalView
ActiveWindow.View.Type = wdPrintView
End Sub
1.27. 彻底删除页眉页脚Sub 彻底删除页眉页脚()
'此宏为雨雪霏霏试写。思路来自：
'①konggs版主于2005-7-26 20:38、2005-7-27 08:51发表的帖子，
'链接为http://club.excelhome.net/viewthread.php?tid=112178；
'②守柔版主于2005-7-27年发表于站内的文章《Word中鲜为人知的三招》，
'链接为http://www.excelhome.cn/Article/ShowArticle.asp?ArticleID=439。
'此宏不足处在于：
'①刪除页眉页脚后不能再恢复；
'②本地文档进行删除操作后不保存退出的话，会在下次启动Word时出现文档恢复窗格。
Dim w, y As String
Application.ScreenUpdating = False
Set w = ActiveDocument.HTMLProject.HTMLProjectItems(2)
If ActiveDocument.HTMLProject.HTMLProjectItems.Count = 2 Then
If w.Name = "header.htm" Then
w.Text = ""
ActiveDocument.HTMLProject.RefreshProject
ActiveDocument.HTMLProject.RefreshDocument
If ActiveDocument.Name Like "*.doc" Then
MsgBox "本文档页眉页脚已彻底清除，请及时保存。" & Chr(13) & _
"若退出本地文档时未保存，重新启动Word时将出现恢复窗格。", vbExclamation, "ExcelHome"
Else
Exit Sub
End If
End If
Else
MsgBox "本文档当前未设置页眉页脚，不需要进行删除操作。", vbOKOnly, "ExcelHome"
End If
Application.ScreenUpdating = True
End Sub
1.28. 切换纵横向页面Sub 切换纵横向页面()
'在"纵向页面"与"横向页面"间切换。
If ActiveDocument.PageSetup.Orientation = wdOrientLandscape Then
ActiveDocument.PageSetup.Orientation = wdOrientPortrait
Else
ActiveDocument.PageSetup.Orientation = wdOrientLandscape
End If
End Sub