进步求实 / 工作 / word宏代码集锦

   

word宏代码集锦

2018-01-16  进步求实

Word宏代码集锦

Word宏代码集锦

一、       修改word格式:

1、' 智能清除选区软回车(换行符)

2、' 清除选区多余空段

3、' 合并选区中“,”结束的多余分段

4、' 清除选区单字节空格

5、' 清除选区单字节空格

6、' 清除选区1字空格

7、' 清除选区段首2字空格

8、' 清除选区Tab

9、' 增加选区空格

10、' 选区段首缩进0

11、' 选区段首缩进:2

12、' 选区段首缩进转空格—已完美

13、' 选区段后间距1

14、' 选区段后间距1

15、' 选区段后间距1

16、' 清除选区图片

17、' 选区硬回车转软回车

18、' 清除选区软回车

19' 合并选区段落

20、' 选区空格转硬回车

21、' 选区标点半角转全角

22、' 选区标点全角转半角

23、' 选区中文句号转半角

24、’把文档第一段设置为标题1的格式

25、选中的文本横向居中

26、缩小字距

27、增大字距

28、缩小行距

29、增大行距

30、等高变宽

31、等高变窄

32、字表间距

33、纵向16

34、插入页码

35、小写金额转大写金额

二、       其它

1.调整图片大小

2.转字体

3.转文件格式

4、文件加密

5、字符替换

6、替换引号

7、打印为PDF格式文件

8、朗读文本

9. 文献标号上标化

10. 箭头上方加文字

11 添加参考文献格式一,参考文献在文档末尾以1 2 3 格式排列

12. 添加参考文献格式二,参考文献在文档末尾以[1] [2] [3] 格式排列,修改自格式一的代码

13. 返回正文

14. 再次引用已有参考文献

15. 查找被删参考文献遗留引用,

16统计修订的字数

17、快速提取脚注内容

18、从任意页面编排页码

19、批量实现缩放打印

20、对文档内容进行顺序排列

21、替换Word文档插图的超链接

22、为文档的每页添加固定内容

23、批量实现图片的等比例缩


一、    修改word格式:

1、' 智能清除选区软回车(换行符)

Sub 智能清除选区软回车()

        With Selection.Find

        .Text = "?^l"

        .Replacement.Text = "^&^p"

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchByte = False

        .MatchAllWordForms = False

        .MatchSoundsLike = False

        .MatchWildcards = True

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^1^l"

        .Replacement.Text = "^&^p"

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^l"

        .Replacement.Text = ""

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

End Sub

 

2、' 清除选区多余空段

Sub 清除选区多余空段()

    With Selection.Find

        .Text = "^p^p"

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^p^p^p"

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^p^p^p"

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^p^p"

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^p^p"

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^p^p^p"

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^p "

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^p^p"

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^p^p"

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

End Sub

 

3、' 合并选区中“,”结束的多余分段

Sub 合并选区多余分段()

    With Selection.Find

        .Text = "^p"

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

 

    With Selection.Find

        .Text = "^p"

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

 

End Sub

 

 

4、' 清除选区单字节空格

Sub 清除选区单字节空格()

 

   

    With Selection.Find

        .Text = " "

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

 

End Sub

 

5、' 清除选区单字节空格

Sub 清除选区2单字节空格()

    With Selection.Find

        .Text = "  "

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

 

6、' 清除选区1字空格

Sub 清除选区1字空格()

    With Selection.Find

        .Text = " "

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

 

End Sub

 

7、' 清除选区段首2字空格

Sub 清除选区段首2字空格()

   

    With Selection.Find

        .Text = "  "

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

 

End Sub

 

8、' 清除选区Tab

Sub 清除选区Tab()

    With Selection.Find

        .Text = vbTab

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

 

End Sub

 

9、' 增加选区空格

Sub 增加选区空格()

    With Selection.Find

        .Text = " "

        .Replacement.Text = "  "

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

End Sub

 

10、' 选区段首缩进0字

Sub 选区段首无缩进()

With Selection.Find

        .Text = " "

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)        '左缩进0字符

        .RightIndent = CentimetersToPoints(0)       '右缩进0字符

        .FirstLineIndent = CentimetersToPoints(0)   '首行缩进点0公分

        .CharacterUnitLeftIndent = 0                   '左缩进单位0字符

        .CharacterUnitRightIndent = 0                  '右缩进单位0字符

        .CharacterUnitFirstLineIndent = 0

    End With

   

    With Selection.ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)        '左缩进1字符

        .RightIndent = CentimetersToPoints(0)       '右缩进2字符

        .FirstLineIndent = CentimetersToPoints(0)   '首行缩进点0.35公分

        .CharacterUnitLeftIndent = 0                   '左缩进单位0字符

        .CharacterUnitRightIndent = 0                  '右缩进单位0字符

        .CharacterUnitFirstLineIndent = 0

    End With

 

End Sub

 

11、' 选区段首缩进:2字

Sub 选区段首缩进2()

    With Selection.ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)        '左缩进1字符

        .RightIndent = CentimetersToPoints(0)       '右缩进2字符

        .FirstLineIndent = CentimetersToPoints(0.35)   '首行缩进点单位公分

        .CharacterUnitLeftIndent = 0                   '左缩进单位0字符

        .CharacterUnitRightIndent = 0                  '右缩进单位0字符

        .CharacterUnitFirstLineIndent = 2

    End With

 

End Sub

 

12、' 选区段首缩进转空格—已完美

Sub 选区段首缩进转空格()

   

    Selection.InsertParagraphBefore

 

    Call 选区段首无缩进

   

    With Selection.Find

        .Text = "^p"

        .Replacement.Text = "^p  "

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    Selection.Delete

   

    With Selection.Find

        .Text = "  ^p"

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

End Sub

 

13、' 选区段后间距1行

Sub 选区段后间距1()

    Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)

    Selection.ParagraphFormat.LineUnitAfter = 1

  

End Sub

 

14、' 选区段后间距1行

Sub 选区段前段后间距半行()

    Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)

    Selection.ParagraphFormat.LineUnitBefore = 0.5

    Selection.ParagraphFormat.LineUnitAfter = 0.5

 

End Sub

 

15、' 选区段后间距1行

Sub 选区段前段后无间距()

   

    Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)

    Selection.ParagraphFormat.LineUnitBefore = 0

    Selection.ParagraphFormat.LineUnitAfter = 0

 

End Sub

 

16、' 清除选区图片

Sub 清除选区图片()

   

    With Selection.Find

        .Text = "^1"

        .Replacement.Text = ""

        .MatchWildcards = True

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

End Sub

 

17、' 选区硬回车转软回车

Sub 选区硬回车转软回车()

   

    With Selection.Find

        .Text = "^p"

        .Replacement.Text = "^l"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

End Sub

 

18、' 清除选区软回车

Sub 清除选区软回车()

  With Selection.Find

        .Text = "^l"

        .Replacement.Text = ""

        .MatchWildcards = True

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

End Sub

 

19' 合并选区段落

Sub 合并选区段落()

    With Selection.Find

        .Text = "  "

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

 

    With Selection.Find

        .Text = "^p"

        .Replacement.Text = "^l"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "^l"

        .Replacement.Text = ""

        .MatchWildcards = True

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    Selection.Paragraphs.Add    '添加段落符号

   

 End Sub

 

20、' 选区空格转硬回车

Sub 选区空格转硬回车()

    With Selection.Find

        .Text = " "

        .Replacement.Text = "^p"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

 

End Sub

 

21、' 选区标点半角转全角

Sub 选区标点半角转全角()

    With Selection.Find

        .Text = ","

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = ";"

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = ":"

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "?"

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "!"

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "......"

        .Replacement.Text = "……"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "."

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

End Sub

 

22、' 选区标点全角转半角

 Sub 选区标点全角转半角()

    With Selection.Find

        .Text = ""

        .Replacement.Text = ","

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = ""

        .Replacement.Text = ";"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = ""

        .Replacement.Text = ":"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = ""

        .Replacement.Text = "?"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = ""

        .Replacement.Text = "!"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = "……"

        .Replacement.Text = "......"

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.Find

        .Text = ""

        .Replacement.Text = "."

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

End Sub

 

23、' 选区中文句号转半角

Sub 选区中文句号转半角()

    With Selection.Find

        .Text = ""

        .Replacement.Text = "."

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

 

End Sub

 

24、’把文档第一段设置为标题1的格式

Sub 标题1()

    ActiveDocument.Paragraphs(1).Style = ActiveDocument.Styles("标题 1")

    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

 

End Sub

 

25、选中的文本横向居中

Sub 横向居中()

With Selection.Find

        .Text = " "

        .Replacement.Text = ""

        .MatchWildcards = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

   

    With Selection.ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)        '左缩进0字符

        .RightIndent = CentimetersToPoints(0)       '右缩进0字符

        .FirstLineIndent = CentimetersToPoints(0)   '首行缩进点0公分

        .CharacterUnitLeftIndent = 0                   '左缩进单位0字符

        .CharacterUnitRightIndent = 0                  '右缩进单位0字符

        .CharacterUnitFirstLineIndent = 0

    End With

   

    With Selection.ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)        '左缩进1字符

        .RightIndent = CentimetersToPoints(0)       '右缩进2字符

        .FirstLineIndent = CentimetersToPoints(0)   '首行缩进点0.35公分

        .CharacterUnitLeftIndent = 0                   '左缩进单位0字符

        .CharacterUnitRightIndent = 0                  '右缩进单位0字符

        .CharacterUnitFirstLineIndent = 0

    End With

    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

 

End Sub

 

26、缩小字距

Sub 缩小字距()

    Dim b

    On Error Resume Next

    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 If

End Sub

 

 

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 If

End Sub

 

28、缩小行距

Sub 缩小行距()

    Dim b

    On Error Resume Next

    StatusBar = "老刘郑重提示: 该命令会取消行自动对齐到行网格!"

    With Selection.ParagraphFormat

      .AutoAdjustRightIndent = False          '不自动调整右缩进

      .DisableLineHeightGrid = True           '不自动对齐行网格

    End With

    If Selection.ParagraphFormat.LineSpacing = 9999999 Then

        For b = 1 To Selection.Paragraphs.Count

            Selection.Paragraphs(b).LineSpacing = Selection.Paragraphs(b).LineSpacing * 0.95

        Next b

    Else

        Selection.ParagraphFormat.LineSpacing = Selection.ParagraphFormat.LineSpacing * 0.95

    End If

End Sub

 

29、增大行距

Sub 增大行距()

    Dim b

    On Error Resume Next

    StatusBar = "老刘郑重提示: 该命令会取消行自动对齐到行网格!"

    With Selection.ParagraphFormat

      .AutoAdjustRightIndent = False          '不自动调整右缩进

      .DisableLineHeightGrid = True           '不自动对齐行网格

    End With

    If Selection.ParagraphFormat.LineSpacing = 9999999 Then   '当段落间距不等时,此值为9999999

        For b = 1 To Selection.Paragraphs.Count               '得到所选段落总数

            Selection.Paragraphs(b).LineSpacing = Selection.Paragraphs(b).LineSpacing * 1.05

        Next b

    Else

        Selection.ParagraphFormat.LineSpacing = Selection.ParagraphFormat.LineSpacing * 1.05

    End If

End Sub

 

30、等高变宽

Sub 等高变宽()

    On Error Resume Next

    Selection.Font.Scaling = Selection.Font.Scaling + 1

End Sub

 

31、等高变窄

Sub 等高变窄()

    On Error Resume Next

    Selection.Font.Scaling = Selection.Font.Scaling - 1

End Sub

 

32、字表间距

Sub 字表间距()

    On Error Resume Next

    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 "当前位置不在表格中,请重新定义。", vbInformation, "刘厚彬现在轻轻地告诉你"

    End If

End Sub

 

33、纵向16

Sub 纵向16()

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

    Content.End).PageSetup              '插入点之后

'With ActiveDocument.PageSetup        '整篇文档

With Selection.PageSetup              '本节

    .Orientation = wdOrientPortrait     '纵向

    .TopMargin = MillimetersToPoints(24)

    .BottomMargin = MillimetersToPoints(25)

    .LeftMargin = MillimetersToPoints(28)

    .RightMargin = MillimetersToPoints(25)

    .FooterDistance = MillimetersToPoints(21)

    .PageWidth = MillimetersToPoints(196)

    .PageHeight = MillimetersToPoints(270)

    .FirstPageTray = wdPrinterDefaultBin

    .OtherPagesTray = wdPrinterDefaultBin

End With

End Sub

 

 

34、插入页码

Sub 插入页码()

    Dim fstpg As Byte

    Dim mydialog As Dialog

    Dim a As String

    On Error Resume Next

    fstpg = 1

    ActiveWindow.View.ShowFieldCodes = False '隐藏窗口域代码

    Set mydialog = Dialogs(wdDialogInsertPageNumbers)

    If mydialog.Display = -1 Then             '-2关闭;-1确定;0取消;1第一个按钮,2第二个按钮,以此类推。

      If mydialog.firstpage = False Then      '判断首页是否打印页码

        mydialog.firstpage = True

        fstpg = False

      End If

      mydialog.Execute

      ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter   '切换到页脚

      Selection.SetRange Start:=0, End:=4     '选定前3个字符文本

      If VBA.Mid$(Selection.text, 1, 1) <> "—" Then

        Selection.EndKey Unit:=wdLine

        Selection.TypeText text:=" —"

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

        Selection.TypeText text:="— "

        Selection.ParagraphFormat.CharacterUnitRightIndent = 0.75

        Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 1.19

      End If

      If fstpg = False Then

        mydialog.firstpage = False

        mydialog.Execute                      '首页不显示页码

      End If

      ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

    End If

End Sub

 

 

35、小写金额转大写金额

Sub 大写金额()

Dim BigNum, snum, i, mydata As DataObject

On Error GoTo e

Set mydata = New DataObject

BigNum = ""

snum = Selection.text

If IsNumeric(snum) = False Then

    mydata.GetFromClipboard             '从剪切板取值

    snum = mydata.GetText(1)

End If

snum = VBA.Trim(VBA.str(Int(Round(snum, 2) * 100)))

If snum < 0 Then snum = -snum: BigNum = ""

If snum = 0 Then

    BigNum = "零元整"

Else

    Const cNum = "零壹贰叁肆伍陆柒捌玖-万仟佰拾亿仟佰拾万仟佰拾元角分"

    Const cCha = "零仟零佰零拾零零零零零亿零万零元亿万零角零分零整-零零零零零亿万元亿零整整"

      For i = 1 To Len(snum) '逐位转换

        BigNum = BigNum + VBA.Mid(cNum, (VBA.Mid(snum, i, 1)) + 1, 1) + VBA.Mid(cNum, 26 - Len(snum) + i, 1)

      Next i

      BigNum = Replace(BigNum, "零亿", "亿零")

      BigNum = Replace(BigNum, "零万", "万零")

      BigNum = Replace(BigNum, "零元", "元零")

      For i = 0 To 11 '去掉多余的零

        BigNum = Replace(BigNum, VBA.Mid(cCha, i * 2 + 1, 2), VBA.Mid(cCha, i + 26, 1))

      Next i

   End If

   Selection.MoveRight

   Selection.TypeText text:=BigNum

   End

e:

   MsgBox "你输入数字错误或太大!请重新输入。", vbExclamation + vbOKOnly, "提示"

End Sub

 

36去掉空白行

Sub 去掉空白行()

    Selection.HomeKey Unit:=wdStory

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

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

        .Replacement.Text = "^13"

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchByte = False

        .MatchAllWordForms = False

        .MatchSoundsLike = False

        .MatchWildcards = True

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    Application.GoBack

End Sub

 

37、查找替换

Sub 查找替换()

    With ActiveDocument.Content.Find

        .ClearFormatting    '清除格式设置

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

        With .Replacement    '替换条件

            .ClearFormatting    '清除格式设置

            .Font.Name = "黑体   '替换成黑体

        End With

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

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

    End With

End Sub

38、总结:word自动化排版宏

Sub 格式设置()

 '

 格式设置 Macro

 

    Application.ScreenUpdating False

     '更改所有硬回车为软回车

     Selection.Find.ClearFormatting

     Selection.Find.Replacement.ClearFormatting

     With Selection.Find

         .Text "^l"

         .Replacement.Text "^p"

         .Forward True

         .Wrap wdFindContinue

         .Format False

         .MatchCase False

         .MatchWholeWord False

         .MatchByte True

         .MatchWildcards False

         .MatchSoundsLike False

         .MatchAllWordForms False

     End With

     Selection.Find.Execute Replace:=wdReplaceAll

     '去除所有空行

     Dim As Paragraph, As Integer

     Application.ScreenUpdating False

     For Each In ActiveDocument.Paragraphs

     If Len(i.Range) Then

     i.Range.Delete

     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 "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ,./<>?;:[]{}\|=-+_)(

         bjsz "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ,。/《》?;':【】{}\|=-+_)(

         Selection.WholeStory

     For iii 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字符

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

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

     Selection.ClearFormatting  '清除首行格式

     Selection.ParagraphFormat.Alignment wdAlignParagraphCenter  '设置首行居中对齐

     Selection.ParagraphFormat.LineUnitBefore  '设置首行段前间距1

     Selection.ParagraphFormat.LineUnitAfter  '设置首行段后间距1

     Selection.Font.Name "微软雅黑 '设置首行字体为“微软雅黑”

     Selection.Font.Size 18  '设置首行字号为18

     Selection.Font.Bold wdToggle  '设置首行字形为加粗

     Application.ScreenUpdating True

 End Sub

 

二、    其它

1.调整图片大小

Sub setpicsize() '设置图片大小

Dim n '图片个数

On Error Resume Next '忽略错误

For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片

ActiveDocument.InlineShapes(n).Height = 400 '设置图片高度为 400px

ActiveDocument.InlineShapes(n).Width = 300 '设置图片宽度 300px

Next n

For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片

ActiveDocument.Shapes(n).Height = 400 '设置图片高度为 400px

ActiveDocument.Shapes(n).Width = 300 '设置图片宽度 300px

Next n

End Sub

 

2.转字体

Sub 批量设置小5号字体() '此代码为指定文件夹中所有选取的WORD文件的进行格式设置

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

' On Error Resume Next '忽略错误

'定义一个文件夹选取对话框

Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)

With MyDialog

.Title = "请选择要处理的文档(可多选)"

.Filters.Clear '清除所有文件筛选器中的项目

.Filters.Add "所有WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件

.AllowMultiSelect = True '允许多项选择

If .Show = -1 Then '确定

Application.ScreenUpdating = False

For Each vrtSelectedItem In .SelectedItems '在所有选取项目中循环

Set Doc = Documents.Open(FileName:=vrtSelectedItem, Visible:=False)

With Doc

 

With .Content

With .Font

' .NameFarEast = "宋体" '中文字体,已禁用

' .NameAscii = "Times New Roman" '英文字体,已禁用

.Size = 9

End With

End With

.Close True

End With

Next

Application.ScreenUpdating = True

End If

End With

MsgBox "批量设置完毕!", vbInformation

End Sub

 

3.转文件格式

Sub Macro1()

' Macro1 Macro

' 宏在 01-10-31录制

'

    Dim name As String      '文件名

    name = "01"

    ChangeFileOpenDirectory "E:\VB_SOUCE\lib"

  

    For i = 1 To 2124        '文件数2124

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

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

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

            Format:=wdOpenFormatAuto

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

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

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

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

            :=False, SaveAsAOCELetter:=False

        ActiveWindow.Close

      

        name = name + 1

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

    Next i

End Sub

 

 

4、文件加密

 sub  mima()

with   activedocument

.password="123"

.writepassword="456"

end  with

end sub

要注意的方面:第三行是打开权限、第四行是修改权限。

 

5、字符替换

Sub 字符替换() '宏名称,可修改为其他字符

With ActiveDocument.Content.Find '在当前文档中进行查找

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

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

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

End With

End Sub

 

6、替换引号

Sub 替换引号()

Dim Countx As Integer, i As Integer, Sh As Byte '声明变量

'以下代码统计出文中的引号数目(包括""“”)

Countx = 0

On Error Resume Next

With ActiveDocument.Content.Find

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

Countx = Countx + 1

Loop

'以下代码判断引号是否配对出现

Sh = Countx Mod 2

If Sh <> 0 Then

MsgBox "引号不配对!"

Exit Sub '如果引号不配对,则退出宏

End If

End With

For i = 1 To Countx

Sh = i Mod 2 'i值除以2的余数

If Sh <> 0 Then '如果余数不等于0(即为奇数),则将相应的引号替'换为“前z

With ActiveDocument.Content.Find

.Text = """"

.Replacement.Text = "z"

.Execute Replace:=wdReplaceOne, Forward:=True

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

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

 

8、朗读文本

Sub 朗读文本()

    On Error Resume Next

    StatusBar = "老刘郑重提示: 执行该命令后文本如果未朗读完将不能进行其他操作!"

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

End Sub

 

 

 

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 = "\[[-9,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 = "[-9,0-9,~\-\  ]@"

        .Replacement.Text = ""

        .MatchWildcards = True

    End With

   Selection.Find.Execute Replace:=wdReplaceAll

End Sub

 

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键清除此段文字,改填所需文字,酌情增减箭头长度,最后同时按下shiftF9))"

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

    Selection.MoveLeft Unit:=wdWord, Count:=25, Extend:=wdExtend ‘顾经宇的代码是26,改成25更好

End Sub

 

11 添加参考文献格式一,参考文献在文档末尾以12 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

 

12. 添加参考文献格式二,参考文献在文档末尾以[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:="] "

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

    Selection.TypeText Text:="["   

    End Sub

 

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

 

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

 

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

 

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

 

17、快速提取脚注内容

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、批量实现缩放打印

  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、对文档内容进行顺序排列

  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:="http://www.sina.com"
n=n+1
Next
MsgBox "
共替换" &n& "个图片!"
End Sub
 

22、为文档的每页添加固定内容

  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:="
机械制图国家标准"
.GoToNext what:=wdGoToPage
End With
Next
End Sub

 

23、批量实现图片的等比例缩

  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 "您所选的内容中没有域代码!", 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

 

25'完美显示图片表格的普通视图

Sub 完美显示图片表格的普通视图()

'此宏为雨雪霏霏特别奉献的小偏方,欢迎各位朋友测试。

'如果文档中的嵌入式图片、表格显示迟滞、错位,运行此宏,将在普通视图下完美显示它们。

 

 

    ActiveDocument.PrintPreview

    ActiveDocument.ClosePrintPreview

    ActiveWindow.View.Type = wdNormalView

End Sub

 

 

'26、完美显示图片表格的页面视图

Sub 完美显示图片表格的页面视图()

'此宏为雨雪霏霏特别奉献的小偏方,欢迎各位朋友测试。

'如果文档中的各种图片、表格显示迟滞、错位,运行此宏,将在页面视图下完美显示它们。

 

 

    ActiveDocument.PrintPreview

    ActiveDocument.ClosePrintPreview

    ActiveWindow.View.Type = wdNormalView

    ActiveWindow.View.Type = wdPrintView

End Sub

 

 

'27、彻底删除页眉页脚

Sub 彻底删除页眉页脚()

'此宏为雨雪霏霏试写。思路来自:

'konggs版主于2005-7-26 20:382005-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

 

 

'28、切换纵横向页面

Sub 切换纵横向页面()

'"纵向页面""横向页面"间切换。

 

 

    If ActiveDocument.PageSetup.Orientation = wdOrientLandscape Then

        ActiveDocument.PageSetup.Orientation = wdOrientPortrait

    Else

        ActiveDocument.PageSetup.Orientation = wdOrientLandscape

    End If

End Sub

    本站是提供个人知识管理的网络存储空间,所有内容均由用户发布,不代表本站观点。如发现有害或侵权内容,请点击这里 或 拨打24小时举报电话:4000070609 与我们联系。

    0条评论

    发表

    请遵守用户 评论公约

    类似文章
    喜欢该文的人也喜欢 更多

    ×
    ×

    ¥.00

    微信或支付宝扫码支付:

    《个图VIP服务协议》

    全部>>