一、    修改word格式：

1、' 智能清除選區(qū)軟回車（換行符）

Sub 智能清除選區(qū)軟回車()

        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、' 清除選區(qū)多余空段

Sub 清除選區(qū)多余空段()

    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、' 合并選區(qū)中“，”結(jié)束的多余分段

Sub 合并選區(qū)多余分段()

    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、' 清除選區(qū)單字節(jié)空格

Sub 清除選區(qū)單字節(jié)空格()

    With Selection.Find

        .Text = " "

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

5、' 清除選區(qū)單字節(jié)空格

Sub 清除選區(qū)2單字節(jié)空格()

    With Selection.Find

        .Text = "  "

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

6、' 清除選區(qū)1字空格

Sub 清除選區(qū)1字空格()

    With Selection.Find

        .Text = "　"

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

7、' 清除選區(qū)段首2字空格

Sub 清除選區(qū)段首2字空格()

    With Selection.Find

        .Text = "　　"

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

8、' 清除選區(qū)Tab

Sub 清除選區(qū)Tab()

    With Selection.Find

        .Text = vbTab

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

9、' 增加選區(qū)空格

Sub 增加選區(qū)空格()

    With Selection.Find

        .Text = "　"

        .Replacement.Text = "　　"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

10、' 選區(qū)段首縮進(jìn)0字

Sub 選區(qū)段首無縮進(jìn)()

With Selection.Find

        .Text = "　"

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    With Selection.ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)        '左縮進(jìn)0字符

        .RightIndent = CentimetersToPoints(0)       '右縮進(jìn)0字符

        .FirstLineIndent = CentimetersToPoints(0)   '首行縮進(jìn)點(diǎn)0公分

        .CharacterUnitLeftIndent = 0                   '左縮進(jìn)單位0字符

        .CharacterUnitRightIndent = 0                  '右縮進(jìn)單位0字符

        .CharacterUnitFirstLineIndent = 0

    End With

    With Selection.ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)        '左縮進(jìn)1字符

        .RightIndent = CentimetersToPoints(0)       '右縮進(jìn)2字符

        .FirstLineIndent = CentimetersToPoints(0)   '首行縮進(jìn)點(diǎn)0.35公分

        .CharacterUnitLeftIndent = 0                   '左縮進(jìn)單位0字符

        .CharacterUnitRightIndent = 0                  '右縮進(jìn)單位0字符

        .CharacterUnitFirstLineIndent = 0

    End With

End Sub

11、' 選區(qū)段首縮進(jìn):2字

Sub 選區(qū)段首縮進(jìn)2字()

    With Selection.ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)        '左縮進(jìn)1字符

        .RightIndent = CentimetersToPoints(0)       '右縮進(jìn)2字符

        .FirstLineIndent = CentimetersToPoints(0.35)   '首行縮進(jìn)點(diǎn)單位公分

        .CharacterUnitLeftIndent = 0                   '左縮進(jìn)單位0字符

        .CharacterUnitRightIndent = 0                  '右縮進(jìn)單位0字符

        .CharacterUnitFirstLineIndent = 2

    End With

End Sub

12、' 選區(qū)段首縮進(jìn)轉(zhuǎn)空格—已完美

Sub 選區(qū)段首縮進(jìn)轉(zhuǎn)空格()

    Selection.InsertParagraphBefore

    Call 選區(qū)段首無縮進(jìn)

    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、' 選區(qū)段后間距1行

Sub 選區(qū)段后間距1行()

    Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)

    Selection.ParagraphFormat.LineUnitAfter = 1

End Sub

14、' 選區(qū)段后間距1行

Sub 選區(qū)段前段后間距半行()

    Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)

    Selection.ParagraphFormat.LineUnitBefore = 0.5

    Selection.ParagraphFormat.LineUnitAfter = 0.5

End Sub

15、' 選區(qū)段后間距1行

Sub 選區(qū)段前段后無間距()

    Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)

    Selection.ParagraphFormat.LineUnitBefore = 0

    Selection.ParagraphFormat.LineUnitAfter = 0

End Sub

16、' 清除選區(qū)圖片

Sub 清除選區(qū)圖片()

    With Selection.Find

        .Text = "^1"

        .Replacement.Text = ""

        .MatchWildcards = True

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

17、' 選區(qū)硬回車轉(zhuǎn)軟回車

Sub 選區(qū)硬回車轉(zhuǎn)軟回車()

    With Selection.Find

        .Text = "^p"

        .Replacement.Text = "^l"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

18、' 清除選區(qū)軟回車

Sub 清除選區(qū)軟回車()

'   With Selection.Find

        .Text = "^l"

        .Replacement.Text = ""

        .MatchWildcards = True

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

19' 合并選區(qū)段落

Sub 合并選區(qū)段落()

    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    '添加段落符號(hào)

 End Sub

20、' 選區(qū)空格轉(zhuǎn)硬回車

Sub 選區(qū)空格轉(zhuǎn)硬回車()

    With Selection.Find

        .Text = "　"

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

21、' 選區(qū)標(biāo)點(diǎn)半角轉(zhuǎn)全角

Sub 選區(qū)標(biāo)點(diǎn)半角轉(zhuǎn)全角()

    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、' 選區(qū)標(biāo)點(diǎn)全角轉(zhuǎn)半角

 Sub 選區(qū)標(biāo)點(diǎn)全角轉(zhuǎn)半角()

    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、' 選區(qū)中文句號(hào)轉(zhuǎn)半角

Sub 選區(qū)中文句號(hào)轉(zhuǎn)半角()

    With Selection.Find

        .Text = "。"

        .Replacement.Text = "."

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

24、’把文檔第一段設(shè)置為標(biāo)題1的格式

Sub 標(biāo)題1()

    ActiveDocument.Paragraphs(1).Style = ActiveDocument.Styles("標(biāo)題 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)        '左縮進(jìn)0字符

        .RightIndent = CentimetersToPoints(0)       '右縮進(jìn)0字符

        .FirstLineIndent = CentimetersToPoints(0)   '首行縮進(jìn)點(diǎn)0公分

        .CharacterUnitLeftIndent = 0                   '左縮進(jìn)單位0字符

        .CharacterUnitRightIndent = 0                  '右縮進(jìn)單位0字符

        .CharacterUnitFirstLineIndent = 0

    End With

    With Selection.ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)        '左縮進(jìn)1字符

        .RightIndent = CentimetersToPoints(0)       '右縮進(jìn)2字符

        .FirstLineIndent = CentimetersToPoints(0)   '首行縮進(jìn)點(diǎn)0.35公分

        .CharacterUnitLeftIndent = 0                   '左縮進(jìn)單位0字符

        .CharacterUnitRightIndent = 0                  '右縮進(jìn)單位0字符

        .CharacterUnitFirstLineIndent = 0

    End With

    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

End Sub

26、縮小字距

Sub 縮小字距()

    Dim b

    On Error Resume Next

    ActiveDocument.Compatibility(wdSpacingInWholePoints) = False        '不按點(diǎn)陣縮放字距

    If Selection.Font.Spacing = 9999999 Then     '當(dāng)字距不等時(shí),此值為9999999

        For b = 1 To Selection.Characters.Count '得到所選字符總數(shù)

            Selection.Characters(b).Font.Spacing = Selection.Characters(b).Font.Spacing - 0.1 '為每個(gè)字符更改字距

        Next b

    Else

        Selection.Font.Spacing = Selection.Font.Spacing - 0.1

    End If

End Sub

27、增大字距

Sub 增大字距()

    On Error Resume Next

    ActiveDocument.Compatibility(wdSpacingInWholePoints) = False        '不按點(diǎn)陣縮放字距

    Dim b

    If Selection.Font.Spacing = 9999999 Then     '當(dāng)字距不等時(shí),此值為9999999

        For b = 1 To Selection.Characters.Count '得到所選字符總數(shù)

            Selection.Characters(b).Font.Spacing = Selection.Characters(b).Font.Spacing + 0.1 '為每個(gè)字符更改字距

        Next b

    Else

        Selection.Font.Spacing = Selection.Font.Spacing + 0.1

    End If

End Sub

28、縮小行距

Sub 縮小行距()

    Dim b

    On Error Resume Next

    StatusBar = "老劉鄭重提示: 該命令會(huì)取消行自動(dòng)對(duì)齊到行網(wǎng)格！"

    With Selection.ParagraphFormat

      .AutoAdjustRightIndent = False          '不自動(dòng)調(diào)整右縮進(jìn)

      .DisableLineHeightGrid = True           '不自動(dòng)對(duì)齊行網(wǎng)格

    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 = "老劉鄭重提示: 該命令會(huì)取消行自動(dòng)對(duì)齊到行網(wǎng)格！"

    With Selection.ParagraphFormat

      .AutoAdjustRightIndent = False          '不自動(dòng)調(diào)整右縮進(jìn)

      .DisableLineHeightGrid = True           '不自動(dòng)對(duì)齊行網(wǎng)格

    End With

    If Selection.ParagraphFormat.LineSpacing = 9999999 Then   '當(dāng)段落間距不等時(shí),此值為9999999

        For b = 1 To Selection.Paragraphs.Count               '得到所選段落總數(shù)

            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

    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 = False

a:

    If Err = 4605 Then

       MsgBox "當(dāng)前位置不在表格中,請(qǐng)重新定義。", vbInformation, "劉厚彬現(xiàn)在輕輕地告訴你"

    End If

End Sub

33、縱向16開

Sub 縱向16開()

' With ActiveDocument.Range(Start:=Selection.Start, End:=ActiveDocument. _

    Content.End).PageSetup              '插入點(diǎn)之后

'With ActiveDocument.PageSetup        '整篇文檔

With Selection.PageSetup              '本節(jié)

    .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關(guān)閉；-1確定；0取消；1第一個(gè)按鈕，2第二個(gè)按鈕，以此類推。

      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個(gè)字符文本

      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、小寫金額轉(zhuǎn)大寫金額

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 = "負(fù)"

If snum = 0 Then

    BigNum = "零元整"

Else

    Const cNum = "零壹貳叁肆伍陸柒捌玖-萬仟佰拾億仟佰拾萬仟佰拾元角分"

    Const cCha = "零仟零佰零拾零零零零零億零萬零元億萬零角零分零整-零零零零零億萬元億零整整"

      For i = 1 To Len(snum) '逐位轉(zhuǎn)換

        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 "你輸入數(shù)字錯(cuò)誤或太大!請(qǐng)重新輸入。", vbExclamation + vbOKOnly, "提示"

End Sub

36、’去掉空白行

Sub 去掉空白行()

    Selection.HomeKey Unit:=wdStory

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = "[^11^13]{2,}"

        .Replacement.Text = "^13"

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchByte = False

        .MatchAllWordForms = False

        .MatchSoundsLike = False

        .MatchWildcards = True

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    Application.GoBack

End Sub

37、查找替換

Sub 查找替換()

    With ActiveDocument.Content.Find

        .ClearFormatting    '清除格式設(shè)置

        .Font.Name = "新宋體"    '查找的字體格式

        With .Replacement    '替換條件

            .ClearFormatting    '清除格式設(shè)置

            .Font.Name = "黑體"    '替換成黑體

        End With

        .Execute findtext:="", ReplaceWith:="", Format:=True, _

                 Replace:=wdReplaceAll    '是格式替換,全部替換

    End With

End Sub

38、總結(jié)：word自動(dòng)化排版宏

Sub 格式設(shè)置()

 '

 ' 格式設(shè)置 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

     '替換非標(biāo)準(zhǔn)引號(hào)為標(biāo)準(zhǔn)引號(hào)

     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

     '字母數(shù)字符號(hào)全角轉(zhuǎn)半角 Macro

     Dim qjsz, bjsz As String, iii As Integer '定義qjsz(全角數(shù)字)、bjsz(半角數(shù)字)為字符串型，iii為整數(shù)型

         qjsz = "０１２３４５６７８９ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ,./<>?;’:[]{}\|=-+_)(

         bjsz = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ，。／《》？；'：【】｛｝＼｜＝－＋＿）（

         Selection.WholeStory

     For iii = 1 To 95 '循環(huán)10次

     With Selection.Find

        .Text = Mid(qjsz, iii, 1) 'mid函數(shù)：返回文本字符串中從指定位置開始的特定數(shù)目的字符，每次取一個(gè)數(shù)字

        .Replacement.Text = Mid(bjsz, iii, 1) '將用于替換的相應(yīng)位置的半角數(shù)字

        .Format = False '保留替換前的字符格式

        .MatchWildcards = False

        .Execute Replace:=wdReplaceAll '用半角符號(hào)替換全角符號(hào)

     End With

     Next iii

     '修改小數(shù)點(diǎn)錯(cuò)誤

     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

     '設(shè)置字號(hào)

     Selection.WholeStory  '全選

     Selection.ClearFormatting  '清除全文格式

     Selection.Font.Size = 14  '設(shè)置字號(hào)為14號(hào)

     '設(shè)置行距

     Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly

     Selection.ParagraphFormat.LineSpacing = 25

     Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify  '設(shè)置文本為兩端對(duì)齊

     Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 2  '設(shè)置段首縮進(jìn)2字符

     Selection.HomeKey Unit:=wdStory  '移至文首

     Selection.EndKey Unit:=wdLine, Extend:=wdExtend  '選中首行

     Selection.ClearFormatting  '清除首行格式

     Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter  '設(shè)置首行居中對(duì)齊

     Selection.ParagraphFormat.LineUnitBefore = 1  '設(shè)置首行段前間距1行

     Selection.ParagraphFormat.LineUnitAfter = 1  '設(shè)置首行段后間距1行

     Selection.Font.Name = "微軟雅黑"  '設(shè)置首行字體為“微軟雅黑”

     Selection.Font.Size = 18  '設(shè)置首行字號(hào)為18號(hào)

     Selection.Font.Bold = wdToggle  '設(shè)置首行字形為加粗

     Application.ScreenUpdating = True

 End Sub

二、    其它

1.調(diào)整圖片大小

Sub setpicsize() '設(shè)置圖片大小

Dim n '圖片個(gè)數(shù)

On Error Resume Next '忽略錯(cuò)誤

For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes類型圖片

ActiveDocument.InlineShapes(n).Height = 400 '設(shè)置圖片高度為 400px

ActiveDocument.InlineShapes(n).Width = 300 '設(shè)置圖片寬度 300px

Next n

For n = 1 To ActiveDocument.Shapes.Count 'Shapes類型圖片

ActiveDocument.Shapes(n).Height = 400 '設(shè)置圖片高度為 400px

ActiveDocument.Shapes(n).Width = 300 '設(shè)置圖片寬度 300px

Next n

End Sub

2.轉(zhuǎn)字體

Sub 批量設(shè)置小5號(hào)字體() '此代碼為指定文件夾中所有選取的WORD文件的進(jìn)行格式設(shè)置

Dim MyDialog As FileDialog, vrtSelectedItem As Variant, Doc As Document

' On Error Resume Next '忽略錯(cuò)誤

'定義一個(gè)文件夾選取對(duì)話框

Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)

With MyDialog

.Title = "請(qǐng)選擇要處理的文檔（可多選）"

.Filters.Clear '清除所有文件篩選器中的項(xiàng)目

.Filters.Add "所有WORD 文件", "*.doc", 1 '增加篩選器的項(xiàng)目為所有WORD文件

.AllowMultiSelect = True '允許多項(xiàng)選擇

If .Show = -1 Then '確定

Application.ScreenUpdating = False

For Each vrtSelectedItem In .SelectedItems '在所有選取項(xiàng)目中循環(huán)

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 "批量設(shè)置完畢!", vbInformation

End Sub

3.轉(zhuǎn)文件格式

Sub Macro1()

' Macro1 Macro

' 宏在 01-10-31錄制

'

    Dim name As String      '文件名

    name = "01"

    ChangeFileOpenDirectory "E:\VB_SOUCE\lib"

    For i = 1 To 2124        '文件數(shù)2124

        Documents.Open filename:=name & ".txt", ConfirmConversions:=False, ReadOnly:= _

            False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _

            "", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _

            Format:=wdOpenFormatAuto

        ActiveDocument.SaveAs filename:=name & ".txt", FileFormat:= _

            wdFormatTextLineBreaks, LockComments:=False, Password:="", _

            AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _

            EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _

            :=False, SaveAsAOCELetter:=False

        ActiveWindow.Close

        name = name + 1

        If name < 10 Then name = "0" & name

    Next i

End Sub

4、文件加密

 sub  mima（）

with   activedocument

.password="123"

.writepassword="456"

end  with

end sub

‘要注意的方面：第三行是打開權(quán)限、第四行是修改權(quán)限。

5、字符替換

Sub 字符替換() '宏名稱，可修改為其他字符

With ActiveDocument.Content.Find '在當(dāng)前文檔中進(jìn)行查找

.Text = "其它" '被替換的字符

.Replacement.Text = "其他" '替換的字符

.Execute Replace:=wdReplaceAll, Forward:=True '替換全部

End With

End Sub

6、替換引號(hào)

Sub 替換引號(hào)()

Dim Countx As Integer, i As Integer, Sh As Byte '聲明變量

'以下代碼統(tǒng)計(jì)出文中的引號(hào)數(shù)目(包括""“”)

Countx = 0

On Error Resume Next

With ActiveDocument.Content.Find

Do While .Execute(FindText:="""", Forward:=True, Format:=True) = True

Countx = Countx + 1

Loop

'以下代碼判斷引號(hào)是否配對(duì)出現(xiàn)

Sh = Countx Mod 2

If Sh <> 0 Then

MsgBox "引號(hào)不配對(duì)！"

Exit Sub '如果引號(hào)不配對(duì)，則退出宏

End If

End With

For i = 1 To Countx

Sh = i Mod 2 '求i值除以2的余數(shù)

If Sh <> 0 Then '如果余數(shù)不等于0(即為奇數(shù))，則將相應(yīng)的引號(hào)替'換為“前z”

With ActiveDocument.Content.Find

.Text = """"

.Replacement.Text = "前z"

.Execute Replace:=wdReplaceOne, Forward:=True

End With

Else

With ActiveDocument.Content.Find '反之則將相應(yīng)的引號(hào)替換為“后z”

.Text = """"

.Replacement.Text = "后z"

.Execute Replace:=wdReplaceOne, Forward:=True

End With

End If

Next '進(jìn)行下一對(duì)引號(hào)的替換

With ActiveDocument.Content.Find

'以下代碼將所有的“前z”替換為左引號(hào)

.Text = "前z"

.Replacement.Text = "“"

.Execute Replace:=wdReplaceAll, Forward:=True

'以下代碼將所有的“后z”替換為右引號(hào)

.Text = "后z"

.Replacement.Text = "”"

.Execute Replace:=wdReplaceAll, Forward:=True

End With

End Sub

7、打印為PDF格式文件

Sub 打印為PDF格式文件()

On Error GoTo c:

Dim a As Balloon

Dim b As String

b = ActivePrinter

Options.PrintDrawingObjects = True '打印圖形對(duì)象

ActivePrinter = "Acrobat PDFWriter"

ActiveDocument.PrintOut

c:

ActivePrinter = b

End Sub

8、朗讀文本

Sub 朗讀文本()

    On Error Resume Next

    StatusBar = "老劉鄭重提示: 執(zhí)行該命令后文本如果未朗讀完將不能進(jìn)行其他操作！"

    Excel.Application.Speech.Speak (ActiveWindow.Selection)

End Sub

9. 文獻(xiàn)標(biāo)號(hào)上標(biāo)化

Sub 文獻(xiàn)標(biāo)號(hào)上標(biāo)化()

'

' 參考文獻(xiàn)上標(biāo)化 Macro

' 宏在 2006-11-3 由 ***** 創(chuàng)建

'

    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

10. 箭頭上方加文字

Sub 箭頭上方加文字()

'

' 箭頭上方加文字 Macro

' 宏在 2008-4-16 由 ***** 創(chuàng)建

'

    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鍵清除此段文字，改填所需文字，酌情增減箭頭長度，最后同時(shí)按下shift和F9))"

     Selection.MoveLeft Unit:=wdCharacter, Count:=2

    Selection.MoveLeft Unit:=wdWord, Count:=25, Extend:=wdExtend ‘顧經(jīng)宇的代碼是26，改成25更好

End Sub

11 添加參考文獻(xiàn)格式一，參考文獻(xiàn)在文檔末尾以1．2． 3． 格式排列

Sub 添加參考文獻(xiàn)格式一()

'

' 添加參考文獻(xiàn) Macro

' 宏在 2008-4-17 由 ***** 創(chuàng)建

'

    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("默認(rèn)段落字體")

    Selection.MoveRight Unit:=wdCharacter, Count:=1

    Selection.Delete Unit:=wdCharacter, Count:=1

    Selection.TypeText Text:="． "   

End Sub

12. 添加參考文獻(xiàn)格式二，參考文獻(xiàn)在文檔末尾以[1] [2] [3] 格式排列，修改自格式一的代碼

Sub 添加參考文獻(xiàn)格式二()

'

' 添加參考文獻(xiàn) Macro

' 宏在 2008-4-17 由 ***** 創(chuàng)建

'

    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("默認(rèn)段落字體")

    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

13. 返回正文

Sub 返回正文()

'返回正文 Macro

'宏在 2008-4-16 由 ***** 創(chuàng)建

'

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

14. 再次引用已有參考文獻(xiàn)

Sub 引用編號(hào)()

'引用編號(hào) Macro

'宏在 2008-4-16 由 ***** 創(chuàng)建

'

    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

15. 查找被刪參考文獻(xiàn)遺留引用，

Sub 查找被刪編號(hào)()

'要?jiǎng)h除某個(gè)參考文獻(xiàn)，應(yīng)該在原始引用處刪除引用，這樣可以一并刪除參考文獻(xiàn)，而不是在文檔末尾文獻(xiàn)列表處刪除

    Selection.WholeStory

    Selection.Fields.Update

    Selection.Find.ClearFormatting

    With Selection.Find

        .Text = "錯(cuò)誤！未定義書簽。"

    End With

    Selection.Find.Execute

    Selection.MoveLeft Unit:=wdCharacter, Count:=1

    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend

End Sub

16、統(tǒng)計(jì)修訂的字?jǐn)?shù)

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 "增加內(nèi)容" & n1 & "處共" & c1 & "字；刪除內(nèi)容" &
n2 & "處共" & c2 & "字。"
End Sub

17、快速提取腳注內(nèi)容

Sub test()
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

 18、從任意頁面編排頁碼

Sub test()
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
  

19、批量實(shí)現(xiàn)縮放打印

  Sub test()
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
  

20、對(duì)文檔內(nèi)容進(jìn)行順序排列

  Sub macro1()
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

21、替換Word文檔插圖的超鏈接

Sub text()
n = 0
For Eachs In ActiveDocument.Shapes
s.Select
ActiveDocument.Hyperlinks.Add Anchor:=Selection.ShapeRange, _
Address:=" n=n+1
Next
MsgBox "共替換" &n& "個(gè)圖片！"
End Sub
 

22、為文檔的每頁添加固定內(nèi)容

  Sub test()
Dim m As Integer, n As Page
m = Selection.Information(wdNumberOfPagesInDocument)
Selection.HomeKey Unit:=wdStory
For o = 1 To m
With Selection
.TypeText Text:="機(jī)械制圖國家標(biāo)準(zhǔn)"
.GoToNext what:=wdGoToPage
End With
Next
End Sub

23、批量實(shí)現(xiàn)圖片的等比例縮

  Sub test()
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”。

24、提取域代碼

Sub 提取域代碼()

    Dim myRange As Range, myCodes As String

    Set myRange = Selection.Range

    With myRange

        If .Fields.Count = 0 Then

            MsgBox "您所選的內(nèi)容中沒有域代碼!", vbInformation

            Exit Sub