1. 修改word格式

1.1 智能清除选区软回车（换行符）

  1. Sub 智能清除选区软回车()
  2.         With Selection.Find
  3.         .Text = "?^l"
  4.         .Replacement.Text = "^&^p"
  5.         .Forward = True
  6.         .Wrap = wdFindContinue
  7.         .Format = False
  8.         .MatchCase = False
  9.         .MatchWholeWord = False
  10.         .MatchByte = False
  11.         .MatchAllWordForms = False
  12.         .MatchSoundsLike = False
  13.         .MatchWildcards = True
  14.     End With
  15.     Selection.Find.Execute Replace:=wdReplaceAll
  17.     With Selection.Find
  18.         .Text = "^1^l"
  19.         .Replacement.Text = "^&^p"
  20.     End With
  21.     Selection.Find.Execute Replace:=wdReplaceAll
  23.     With Selection.Find
  24.         .Text = "^l"
  25.         .Replacement.Text = ""
  26.     End With
  27.     Selection.Find.Execute Replace:=wdReplaceAll
  29. End Sub

1.2. 清除选区多余空段

  1. Sub 清除选区多余空段()
  2.     With Selection.Find
  3.         .Text = "^p^p"
  4.         .Replacement.Text = "^p"
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9.     With Selection.Find
  10.         .Text = "^p^p^p"
  11.         .Replacement.Text = "^p"
  12.         .MatchWildcards = False
  13.     End With
  14.     Selection.Find.Execute Replace:=wdReplaceAll
  16.     With Selection.Find
  17.         .Text = "^p^p^p"
  18.         .Replacement.Text = "^p"
  19.         .MatchWildcards = False
  20.     End With
  21.     Selection.Find.Execute Replace:=wdReplaceAll
  23.     With Selection.Find
  24.         .Text = "^p^p"
  25.         .Replacement.Text = "^p"
  26.         .MatchWildcards = False
  27.     End With
  28.     Selection.Find.Execute Replace:=wdReplaceAll
  30.     With Selection.Find
  31.         .Text = "^p^p"
  32.         .Replacement.Text = "^p"
  33.         .MatchWildcards = False
  34.     End With
  35.     Selection.Find.Execute Replace:=wdReplaceAll
  37.     With Selection.Find
  38.         .Text = "^p^p^p"
  39.         .Replacement.Text = "^p"
  40.         .MatchWildcards = False
  41.     End With
  42.     Selection.Find.Execute Replace:=wdReplaceAll
  44.     With Selection.Find
  45.         .Text = "^p "
  46.         .Replacement.Text = "^p"
  47.         .MatchWildcards = False
  48.     End With
  49.     Selection.Find.Execute Replace:=wdReplaceAll
  51.     With Selection.Find
  52.         .Text = "^p^p"
  53.         .Replacement.Text = "^p"
  54.         .MatchWildcards = False
  55.     End With
  56.     Selection.Find.Execute Replace:=wdReplaceAll
  58.     With Selection.Find
  59.         .Text = "^p^p"
  60.         .Replacement.Text = "^p"
  61.         .MatchWildcards = False
  62.     End With
  63.     Selection.Find.Execute Replace:=wdReplaceAll
  65. End Sub

1.3. 合并选区中“，”结束的多余分段

  1. Sub 合并选区多余分段()
  2.     With Selection.Find
  3.         .Text = "，^p"
  4.         .Replacement.Text = "，"
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9.     With Selection.Find
  10.         .Text = "、^p"
  11.         .Replacement.Text = "、"
  12.         .MatchWildcards = False
  13.     End With
  14.     Selection.Find.Execute Replace:=wdReplaceAll
  16. End Sub

1.4. 清除选区单字节空格

  1. Sub 清除选区单字节空格()  
  2.     With Selection.Find
  3.         .Text = " "
  4.         .Replacement.Text = ""
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9. End Sub

1.5. 清除选区单字节空格

  1. Sub 清除选区2单字节空格()
  2.     With Selection.Find
  3.         .Text = "  "
  4.         .Replacement.Text = ""
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  8. End Sub

1.6. 清除选区1字空格

  1. Sub 清除选区1字空格()
  2.     With Selection.Find
  3.         .Text = "　"
  4.         .Replacement.Text = ""
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9. End Sub

1.7. 清除选区段首2字空格

  1. Sub 清除选区段首2字空格()
  3.     With Selection.Find
  4.         .Text = "　　"
  5.         .Replacement.Text = ""
  6.         .MatchWildcards = False
  7.     End With
  8.     Selection.Find.Execute Replace:=wdReplaceAll
  10. End Sub

1.8. 清除选区Tab

  1. Sub 清除选区Tab()
  2.     With Selection.Find
  3.         .Text = vbTab
  4.         .Replacement.Text = ""
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9. End Sub

1.9. 增加选区空格

  1. Sub 增加选区空格()
  2.     With Selection.Find
  3.         .Text = "　"
  4.         .Replacement.Text = "　　"
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9. End Sub

1.10. 选区段首缩进0字

  1. Sub 选区段首无缩进()
  2. With Selection.Find
  3.         .Text = "　"
  4.         .Replacement.Text = ""
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9.     With Selection.ParagraphFormat
  10.         .LeftIndent = CentimetersToPoints(0)        '左缩进0字符
  11.         .RightIndent = CentimetersToPoints(0)       '右缩进0字符
  12.         .FirstLineIndent = CentimetersToPoints(0)   '首行缩进点0公分
  13.         .CharacterUnitLeftIndent = 0                   '左缩进单位0字符
  14.         .CharacterUnitRightIndent = 0                  '右缩进单位0字符
  15.         .CharacterUnitFirstLineIndent = 0
  16.     End With
  18.     With Selection.ParagraphFormat
  19.         .LeftIndent = CentimetersToPoints(0)        '左缩进1字符
  20.         .RightIndent = CentimetersToPoints(0)       '右缩进2字符
  21.         .FirstLineIndent = CentimetersToPoints(0)   '首行缩进点0.35公分
  22.         .CharacterUnitLeftIndent = 0                   '左缩进单位0字符
  23.         .CharacterUnitRightIndent = 0                  '右缩进单位0字符
  24.         .CharacterUnitFirstLineIndent = 0
  25.     End With
  27. End Sub

1.11. 选区段首缩进:2字

  1. Sub 选区段首缩进2字()
  2.     With Selection.ParagraphFormat
  3.         .LeftIndent = CentimetersToPoints(0)        '左缩进1字符
  4.         .RightIndent = CentimetersToPoints(0)       '右缩进2字符
  5.         .FirstLineIndent = CentimetersToPoints(0.35)   '首行缩进点单位公分
  6.         .CharacterUnitLeftIndent = 0                   '左缩进单位0字符
  7.         .CharacterUnitRightIndent = 0                  '右缩进单位0字符
  8.         .CharacterUnitFirstLineIndent = 2
  9.     End With
  11. End Sub

1.12. 选区段首缩进转空格—已完美

  1. Sub 选区段首缩进转空格()
  3.     Selection.InsertParagraphBefore
  5.     Call 选区段首无缩进
  7.     With Selection.Find
  8.         .Text = "^p"
  9.         .Replacement.Text = "^p　　"
  10.         .MatchWildcards = False
  11.     End With
  12.     Selection.Find.Execute Replace:=wdReplaceAll
  13.     Selection.Delete
  15.     With Selection.Find
  16.         .Text = "　　^p"
  17.         .Replacement.Text = ""
  18.         .MatchWildcards = False
  19.     End With
  20.     Selection.Find.Execute Replace:=wdReplaceAll
  22. End Sub

1.13. 选区段后间距1行

  1. Sub 选区段后间距1行()
  2.     Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)
  3.     Selection.ParagraphFormat.LineUnitAfter = 1
  5. End Sub

1.14. 选区段前段后间距半行

  1. Sub 选区段前段后间距半行()
  2.     Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)
  3.     Selection.ParagraphFormat.LineUnitBefore = 0.5
  4.     Selection.ParagraphFormat.LineUnitAfter = 0.5
  6. End Sub

1.15. 选区段前段后无间距

  1. Sub 选区段前段后无间距()
  3.     Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)
  4.     Selection.ParagraphFormat.LineUnitBefore = 0
  5.     Selection.ParagraphFormat.LineUnitAfter = 0
  7. End Sub

1.16. 清除选区图片

  1. Sub 清除选区图片()
  3.     With Selection.Find
  4.         .Text = "^1"
  5.         .Replacement.Text = ""
  6.         .MatchWildcards = True
  7.     End With
  8.     Selection.Find.Execute Replace:=wdReplaceAll
  10. End Sub

1.17. 选区硬回车转软回车

  1. Sub 选区硬回车转软回车()
  3.     With Selection.Find
  4.         .Text = "^p"
  5.         .Replacement.Text = "^l"
  6.         .MatchWildcards = False
  7.     End With
  8.     Selection.Find.Execute Replace:=wdReplaceAll
  10. End Sub

1.18. 清除选区软回车

  1. Sub 清除选区软回车()
  2. '   With Selection.Find
  3.         .Text = "^l"
  4.         .Replacement.Text = ""
  5.         .MatchWildcards = True
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9. End Sub

1.19. 合并选区段落

  1. Sub 合并选区段落()
  2.     With Selection.Find
  3.         .Text = "　　"
  4.         .Replacement.Text = ""
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9.     With Selection.Find
  10.         .Text = "^p"
  11.         .Replacement.Text = "^l"
  12.         .MatchWildcards = False
  13.     End With
  14.     Selection.Find.Execute Replace:=wdReplaceAll
  16.     With Selection.Find
  17.         .Text = "^l"
  18.         .Replacement.Text = ""
  19.         .MatchWildcards = True
  20.     End With
  21.     Selection.Find.Execute Replace:=wdReplaceAll
  23.     Selection.Paragraphs.Add    '添加段落符号
  25.  End Sub

1.20. 选区空格转硬回车

  1. Sub 选区空格转硬回车()
  2.     With Selection.Find
  3.         .Text = "　"
  4.         .Replacement.Text = "^p"
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9. End Sub

1.21. 选区标点半角转全角

  1. Sub 选区标点半角转全角()
  2.     With Selection.Find
  3.         .Text = ","
  4.         .Replacement.Text = "，"
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9.     With Selection.Find
  10.         .Text = ";"
  11.         .Replacement.Text = "；"
  12.         .MatchWildcards = False
  13.     End With
  14.     Selection.Find.Execute Replace:=wdReplaceAll
  16.     With Selection.Find
  17.         .Text = ":"
  18.         .Replacement.Text = "："
  19.         .MatchWildcards = False
  20.     End With
  21.     Selection.Find.Execute Replace:=wdReplaceAll
  23.     With Selection.Find
  24.         .Text = "?"
  25.         .Replacement.Text = "？"
  26.         .MatchWildcards = False
  27.     End With
  28.     Selection.Find.Execute Replace:=wdReplaceAll
  30.     With Selection.Find
  31.         .Text = "!"
  32.         .Replacement.Text = "！"
  33.         .MatchWildcards = False
  34.     End With
  35.     Selection.Find.Execute Replace:=wdReplaceAll
  37.     With Selection.Find
  38.         .Text = "......"
  39.         .Replacement.Text = "……"
  40.         .MatchWildcards = False
  41.     End With
  42.     Selection.Find.Execute Replace:=wdReplaceAll
  44.     With Selection.Find
  45.         .Text = "."
  46.         .Replacement.Text = "。"
  47.         .MatchWildcards = False
  48.     End With
  49.     Selection.Find.Execute Replace:=wdReplaceAll
  51. End Sub

1.22. 选区标点全角转半角

  1.  Sub 选区标点全角转半角()
  2.     With Selection.Find
  3.         .Text = "，"
  4.         .Replacement.Text = ","
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9.     With Selection.Find
  10.         .Text = "；"
  11.         .Replacement.Text = ";"
  12.         .MatchWildcards = False
  13.     End With
  14.     Selection.Find.Execute Replace:=wdReplaceAll
  16.     With Selection.Find
  17.         .Text = "："
  18.         .Replacement.Text = ":"
  19.         .MatchWildcards = False
  20.     End With
  21.     Selection.Find.Execute Replace:=wdReplaceAll
  23.     With Selection.Find
  24.         .Text = "？"
  25.         .Replacement.Text = "?"
  26.         .MatchWildcards = False
  27.     End With
  28.     Selection.Find.Execute Replace:=wdReplaceAll
  30.     With Selection.Find
  31.         .Text = "！"
  32.         .Replacement.Text = "!"
  33.         .MatchWildcards = False
  34.     End With
  35.     Selection.Find.Execute Replace:=wdReplaceAll
  37.     With Selection.Find
  38.         .Text = "……"
  39.         .Replacement.Text = "......"
  40.         .MatchWildcards = False
  41.     End With
  42.     Selection.Find.Execute Replace:=wdReplaceAll
  44.     With Selection.Find
  45.         .Text = "。"
  46.         .Replacement.Text = "."
  47.         .MatchWildcards = False
  48.     End With
  49.     Selection.Find.Execute Replace:=wdReplaceAll
  51. End Sub

1.23. 选区中文句号转半角

  1. Sub 选区中文句号转半角()
  2.     With Selection.Find
  3.         .Text = "。"
  4.         .Replacement.Text = "."
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9. End Sub

1.24. 把文档第一段设置为标题1的格式

  1. Sub 标题1()
  2.     ActiveDocument.Paragraphs(1).Style = ActiveDocument.Styles("标题 1")
  3.     Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
  5. End Sub

1.25. 选中的文本横向居中

  1. Sub 横向居中()
  2. With Selection.Find
  3.         .Text = "　"
  4.         .Replacement.Text = ""
  5.         .MatchWildcards = False
  6.     End With
  7.     Selection.Find.Execute Replace:=wdReplaceAll
  9.     With Selection.ParagraphFormat
  10.         .LeftIndent = CentimetersToPoints(0)        '左缩进0字符
  11.         .RightIndent = CentimetersToPoints(0)       '右缩进0字符
  12.         .FirstLineIndent = CentimetersToPoints(0)   '首行缩进点0公分
  13.         .CharacterUnitLeftIndent = 0                   '左缩进单位0字符
  14.         .CharacterUnitRightIndent = 0                  '右缩进单位0字符
  15.         .CharacterUnitFirstLineIndent = 0
  16.     End With
  18.     With Selection.ParagraphFormat
  19.         .LeftIndent = CentimetersToPoints(0)        '左缩进1字符
  20.         .RightIndent = CentimetersToPoints(0)       '右缩进2字符
  21.         .FirstLineIndent = CentimetersToPoints(0)   '首行缩进点0.35公分
  22.         .CharacterUnitLeftIndent = 0                   '左缩进单位0字符
  23.         .CharacterUnitRightIndent = 0                  '右缩进单位0字符
  24.         .CharacterUnitFirstLineIndent = 0
  25.     End With
  26.     Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
  28. End Sub

1.26. 缩小字距

  1. Sub 缩小字距()
  2.     Dim b
  3.     On Error Resume Next
  4.     ActiveDocument.Compatibility(wdSpacingInWholePoints) = False        '不按点阵缩放字距
  5.     If Selection.Font.Spacing = 9999999 Then     '当字距不等时,此值为9999999
  6.         For b = 1 To Selection.Characters.Count '得到所选字符总数
  7.             Selection.Characters(b).Font.Spacing = Selection.Characters(b).Font.Spacing - 0.1 '为每个字符更改字距
  8.         Next b
  9.     Else
  10.         Selection.Font.Spacing = Selection.Font.Spacing - 0.1
  11.     End If
  12. End Sub

1.27. 增大字距

  1. Sub 增大字距()
  2.     On Error Resume Next
  3.     ActiveDocument.Compatibility(wdSpacingInWholePoints) = False        '不按点阵缩放字距
  4.     Dim b
  5.     If Selection.Font.Spacing = 9999999 Then     '当字距不等时,此值为9999999
  6.         For b = 1 To Selection.Characters.Count '得到所选字符总数
  7.             Selection.Characters(b).Font.Spacing = Selection.Characters(b).Font.Spacing + 0.1 '为每个字符更改字距
  8.         Next b
  9.     Else
  10.         Selection.Font.Spacing = Selection.Font.Spacing + 0.1
  11.     End If
  12. End Sub

1.28. 缩小行距

  1. Sub 缩小行距()
  2.     Dim b
  3.     On Error Resume Next
  4.     StatusBar = "老刘郑重提示: 该命令会取消行自动对齐到行网格！"
  5.     With Selection.ParagraphFormat
  6.       .AutoAdjustRightIndent = False          '不自动调整右缩进
  7.       .DisableLineHeightGrid = True           '不自动对齐行网格
  8.     End With
  9.     If Selection.ParagraphFormat.LineSpacing = 9999999 Then
  10.         For b = 1 To Selection.Paragraphs.Count
  11.             Selection.Paragraphs(b).LineSpacing = Selection.Paragraphs(b).LineSpacing * 0.95
  12.         Next b
  13.     Else
  14.         Selection.ParagraphFormat.LineSpacing = Selection.ParagraphFormat.LineSpacing * 0.95
  15.     End If
  16. End Sub

1.29. 增大行距

  1. Sub 增大行距()
  2.     Dim b
  3.     On Error Resume Next
  4.     StatusBar = "老刘郑重提示: 该命令会取消行自动对齐到行网格！"
  5.     With Selection.ParagraphFormat
  6.       .AutoAdjustRightIndent = False          '不自动调整右缩进
  7.       .DisableLineHeightGrid = True           '不自动对齐行网格
  8.     End With
  9.     If Selection.ParagraphFormat.LineSpacing = 9999999 Then   '当段落间距不等时,此值为9999999
  10.         For b = 1 To Selection.Paragraphs.Count               '得到所选段落总数
  11.             Selection.Paragraphs(b).LineSpacing = Selection.Paragraphs(b).LineSpacing * 1.05
  12.         Next b
  13.     Else
  14.         Selection.ParagraphFormat.LineSpacing = Selection.ParagraphFormat.LineSpacing * 1.05
  15.     End If
  16. End Sub

1.30. 等高变宽

  1. Sub 等高变宽()
  2.     On Error Resume Next
  3.     Selection.Font.Scaling = Selection.Font.Scaling + 1
  4. End Sub

1.31. 等高变窄

  1. Sub 等高变窄()
  2.     On Error Resume Next
  3.     Selection.Font.Scaling = Selection.Font.Scaling - 1
  4. End Sub

1.32. 字表间距

  1. Sub 字表间距()
  2.     On Error Resume Next
  3.     ActiveDocument.Compatibility(wdAlignTablesRowByRow) = False
  4.     Selection.Tables(1).Select
  5.     With Selection.Borders(wdBorderTop)
  6.         .LineStyle = wdLineStyleSingle
  7.         .LineWidth = wdLineWidth150pt
  8.         .Color = Options.DefaultBorderColor
  9.     End With
  10.     With Selection.Borders(wdBorderLeft)
  11.         .LineStyle = wdLineStyleSingle
  12.         .LineWidth = wdLineWidth150pt
  13.         .Color = Options.DefaultBorderColor
  14.     End With
  15.     With Selection.Borders(wdBorderBottom)
  16.         .LineStyle = wdLineStyleSingle
  17.         .LineWidth = wdLineWidth150pt
  18.         .Color = Options.DefaultBorderColor
  19.     End With
  20.     With Selection.Borders(wdBorderRight)
  21.         .LineStyle = wdLineStyleSingle
  22.         .LineWidth = wdLineWidth150pt
  23.         .Color = Options.DefaultBorderColor
  24.     End With
  25.     On Error GoTo a:
  26.     Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
  27.     Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
  28.     Selection.Rows.SpaceBetweenColumns = 0
  29.     Selection.Tables(1).AllowAutoFit = False
  30. a:
  31.     If Err = 4605 Then
  32.        MsgBox "当前位置不在表格中,请重新定义。", vbInformation, "刘厚彬现在轻轻地告诉你"
  33.     End If
  34. End Sub

1.33. 纵向16开

  1. Sub 纵向16开()
  2. ' With ActiveDocument.Range(Start:=Selection.Start, End:=ActiveDocument. _
  3.     Content.End).PageSetup              '插入点之后
  4. 'With ActiveDocument.PageSetup        '整篇文档
  5. With Selection.PageSetup              '本节
  6.     .Orientation = wdOrientPortrait     '纵向
  7.     .TopMargin = MillimetersToPoints(24)
  8.     .BottomMargin = MillimetersToPoints(25)
  9.     .LeftMargin = MillimetersToPoints(28)
  10.     .RightMargin = MillimetersToPoints(25)
  11.     .FooterDistance = MillimetersToPoints(21)
  12.     .PageWidth = MillimetersToPoints(196)
  13.     .PageHeight = MillimetersToPoints(270)
  14.     .FirstPageTray = wdPrinterDefaultBin
  15.     .OtherPagesTray = wdPrinterDefaultBin
  16. End With
  17. End Sub

1.34. 插入页码

  1. Sub 插入页码()
  2.     Dim fstpg As Byte
  3.     Dim mydialog As Dialog
  4.     Dim a As String
  5.     On Error Resume Next
  6.     fstpg = 1
  7.     ActiveWindow.View.ShowFieldCodes = False '隐藏窗口域代码
  8.     Set mydialog = Dialogs(wdDialogInsertPageNumbers)
  9.     If mydialog.Display = -1 Then             '-2关闭；-1确定；0取消；1第一个按钮，2第二个按钮，以此类推。
  10.       If mydialog.firstpage = False Then      '判断首页是否打印页码
  11.         mydialog.firstpage = True
  12.         fstpg = False
  13.       End If
  14.       mydialog.Execute
  15.       ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter   '切换到页脚
  16.       Selection.SetRange Start:=0, End:=4     '选定前3个字符文本
  17.       If VBA.Mid$(Selection.text, 1, 1) <> "—" Then
  18.         Selection.EndKey Unit:=wdLine
  19.         Selection.TypeText text:=" —"
  20.         Selection.MoveLeft Unit:=wdCharacter, Count:=5
  21.         Selection.TypeText text:="— "
  22.         Selection.ParagraphFormat.CharacterUnitRightIndent = 0.75
  23.         Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 1.19
  24.       End If
  25.       If fstpg = False Then
  26.         mydialog.firstpage = False
  27.         mydialog.Execute                      '首页不显示页码
  28.       End If
  29.       ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
  30.     End If
  31. End Sub

1.35. 小写金额转大写金额

  1. Sub 大写金额()
  2. Dim BigNum, snum, i, mydata As DataObject
  3. On Error GoTo e
  4. Set mydata = New DataObject
  5. BigNum = ""
  6. snum = Selection.text
  7. If IsNumeric(snum) = False Then
  8.     mydata.GetFromClipboard             '从剪切板取值
  9.     snum = mydata.GetText(1)
  10. End If
  11. snum = VBA.Trim(VBA.str(Int(Round(snum, 2) * 100)))
  12. If snum < 0 Then snum = -snum: BigNum = "负"
  13. If snum = 0 Then
  14.     BigNum = "零元整"
  15. Else
  16.     Const cNum = "零壹贰叁肆伍陆柒捌玖-万仟佰拾亿仟佰拾万仟佰拾元角分"
  17.     Const cCha = "零仟零佰零拾零零零零零亿零万零元亿万零角零分零整-零零零零零亿万元亿零整整"
  18.       For i = 1 To Len(snum) '逐位转换
  19.         BigNum = BigNum + VBA.Mid(cNum, (VBA.Mid(snum, i, 1)) + 1, 1) + VBA.Mid(cNum, 26 - Len(snum) + i, 1)
  20.       Next i
  21.       BigNum = Replace(BigNum, "零亿", "亿零")
  22.       BigNum = Replace(BigNum, "零万", "万零")
  23.       BigNum = Replace(BigNum, "零元", "元零")
  24.       For i = 0 To 11 '去掉多余的零
  25.         BigNum = Replace(BigNum, VBA.Mid(cCha, i * 2 + 1, 2), VBA.Mid(cCha, i + 26, 1))
  26.       Next i
  27.    End If
  28.    Selection.MoveRight
  29.    Selection.TypeText text:=BigNum
  30.    End
  31. e:
  32.    MsgBox "你输入数字错误或太大!请重新输入。", vbExclamation + vbOKOnly, "提示"
  33. End Sub

1.36. 去掉空白行

  1. Sub 去掉空白行()
  2.     Selection.HomeKey Unit:=wdStory
  3.     Selection.Find.ClearFormatting
  4.     Selection.Find.Replacement.ClearFormatting
  5.     With Selection.Find
  6.         .Text = "[^11^13]{2,}"
  7.         .Replacement.Text = "^13"
  8.         .Forward = True
  9.         .Wrap = wdFindContinue
  10.         .Format = False
  11.         .MatchCase = False
  12.         .MatchWholeWord = False
  13.         .MatchByte = False
  14.         .MatchAllWordForms = False
  15.         .MatchSoundsLike = False
  16.         .MatchWildcards = True
  17.     End With
  18.     Selection.Find.Execute Replace:=wdReplaceAll
  19.     Application.GoBack
  20. End Sub

1.37. 查找替换

  1. Sub 查找替换()
  2.     With ActiveDocument.Content.Find
  3.         .ClearFormatting    '清除格式设置
  4.         .Font.Name = "新宋体"    '查找的字体格式
  5.         With .Replacement    '替换条件
  6.             .ClearFormatting    '清除格式设置
  7.             .Font.Name = "黑体"    '替换成黑体
  8.         End With
  9.         .Execute findtext:="", ReplaceWith:="", Format:=True, _
  10.                  Replace:=wdReplaceAll    '是格式替换,全部替换
  11.     End With
  12. End Sub

1.38. 格式设置 Macro

  1. Sub 格式设置()
  2.  '
  3.  ' 格式设置 Macro
  5.     Application.ScreenUpdating = False
  6.      '更改所有硬回车为软回车
  7.      Selection.Find.ClearFormatting
  8.      Selection.Find.Replacement.ClearFormatting
  9.      With Selection.Find
  10.          .Text = "^l"
  11.          .Replacement.Text = "^p"
  12.          .Forward = True
  13.          .Wrap = wdFindContinue
  14.          .Format = False
  15.          .MatchCase = False
  16.          .MatchWholeWord = False
  17.          .MatchByte = True
  18.          .MatchWildcards = False
  19.          .MatchSoundsLike = False
  20.          .MatchAllWordForms = False
  21.      End With
  22.      Selection.Find.Execute Replace:=wdReplaceAll
  23.      '去除所有空行
  24.      Dim i As Paragraph, n As Integer
  25.      Application.ScreenUpdating = False
  26.      For Each i In ActiveDocument.Paragraphs
  27.      If Len(i.Range) = 1 Then
  28.      i.Range.Delete
  29.      n = n + 1
  30.      End If
  31.      Next
  32.      Application.ScreenUpdating = True
  33.      '去除半角空格
  34.      Selection.Find.ClearFormatting
  35.      Selection.Find.Replacement.ClearFormatting
  36.      With Selection.Find
  37.          .Text = " "
  38.          .Replacement.Text = ""
  39.          .Forward = True
  40.          .Wrap = wdFindContinue
  41.          .Format = False
  42.          .MatchCase = False
  43.          .MatchWholeWord = False
  44.          .MatchByte = True
  45.          .MatchWildcards = False
  46.          .MatchSoundsLike = False
  47.          .MatchAllWordForms = False
  48.      End With
  49.      Selection.Find.Execute Replace:=wdReplaceAll
  50.      '去除全角空格
  51.      Selection.Find.ClearFormatting
  52.      Selection.Find.Replacement.ClearFormatting
  53.      With Selection.Find
  54.          .Text = "　"
  55.          .Replacement.Text = ""
  56.          .Forward = True
  57.          .Wrap = wdFindContinue
  58.          .Format = False
  59.          .MatchCase = False
  60.          .MatchWholeWord = False
  61.          .MatchByte = True
  62.          .MatchWildcards = False
  63.          .MatchSoundsLike = False
  64.          .MatchAllWordForms = False
  65.      End With
  66.      Selection.Find.Execute Replace:=wdReplaceAll
  67.      '替换非标准引号为标准引号
  68.      Selection.Find.ClearFormatting
  69.      Selection.Find.Replacement.ClearFormatting
  70.      With Selection.Find
  71.          .Text = """(*)"""
  72.          .Replacement.Text = ChrW(8220) & "\1" & ChrW(8221)
  73.          .Forward = True
  74.          .Wrap = wdFindContinue
  75.          .Format = False
  76.          .MatchCase = False
  77.          .MatchWholeWord = False
  78.          .MatchByte = False
  79.          .MatchAllWordForms = False
  80.          .MatchSoundsLike = False
  81.          .MatchWildcards = True
  82.      End With
  83.      Selection.Find.Execute Replace:=wdReplaceAll
  84.      '字母数字符号全角转半角 Macro
  85.      Dim qjsz, bjsz As String, iii As Integer '定义qjsz(全角数字)、bjsz(半角数字)为字符串型，iii为整数型
  86.          qjsz = "０１２３４５６７８９ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ,./<>?;’:[]{}\|=-+_)(
  87.          bjsz = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ，。／《》？；'：【】｛｝＼｜＝－＋＿）（
  88.          Selection.WholeStory
  89.      For iii = 1 To 95 '循环10次
  90.      With Selection.Find
  91.         .Text = Mid(qjsz, iii, 1) 'mid函数：返回文本字符串中从指定位置开始的特定数目的字符，每次取一个数字
  92.         .Replacement.Text = Mid(bjsz, iii, 1) '将用于替换的相应位置的半角数字
  93.         .Format = False '保留替换前的字符格式
  94.         .MatchWildcards = False
  95.         .Execute Replace:=wdReplaceAll '用半角符号替换全角符号
  96.      End With
  97.      Next iii
  98.      '修改小数点错误
  99.      Selection.Find.ClearFormatting
  100.      Selection.Find.Replacement.ClearFormatting
  101.      With Selection.Find
  102.          .Text = "([0-9])。([0-9])"
  103.          .Replacement.Text = "\1.\2"
  104.          .Forward = True
  105.          .Wrap = wdFindContinue
  106.          .Format = False
  107.          .MatchCase = False
  108.          .MatchWholeWord = False
  109.          .MatchByte = False
  110.          .MatchAllWordForms = False
  111.          .MatchSoundsLike = False
  112.          .MatchWildcards = True
  113.      End With
  114.      Selection.Find.Execute Replace:=wdReplaceAll
  115.      '设置字号
  116.      Selection.WholeStory  '全选
  117.      Selection.ClearFormatting  '清除全文格式
  118.      Selection.Font.Size = 14  '设置字号为14号
  119.      '设置行距
  120.      Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
  121.      Selection.ParagraphFormat.LineSpacing = 25
  122.      Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify  '设置文本为两端对齐
  123.      Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 2  '设置段首缩进2字符
  124.      Selection.HomeKey Unit:=wdStory  '移至文首
  125.      Selection.EndKey Unit:=wdLine, Extend:=wdExtend  '选中首行
  126.      Selection.ClearFormatting  '清除首行格式
  127.      Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter  '设置首行居中对齐
  128.      Selection.ParagraphFormat.LineUnitBefore = 1  '设置首行段前间距1行
  129.      Selection.ParagraphFormat.LineUnitAfter = 1  '设置首行段后间距1行
  130.      Selection.Font.Name = "微软雅黑"  '设置首行字体为“微软雅黑”
  131.      Selection.Font.Size = 18  '设置首行字号为18号
  132.      Selection.Font.Bold = wdToggle  '设置首行字形为加粗
  133.      Application.ScreenUpdating = True
  134.  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