2024年4月15日发(作者：)

Word宏代码集锦

Word宏代码集锦 ............................................................................................................................. 1

一、 修改word格式： ..................................................................................................... 1

1、' 智能清除选区软回车（换行符） ......................................................................... 1

2、' 清除选区多余空段 ................................................................................................. 1

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

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

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

6、' 清除选区1字空格 ................................................................................................. 4

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

8、' 清除选区 5

9、' 增加选区空格 ......................................................................................................... 5

10、' 选区段首缩进0字 ............................................................................................... 5

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

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

13、' 选区段后间距1行 ............................................................................................... 7

14、' 选区段后间距1行 ............................................................................................... 7

15、' 选区段后间距1行 ............................................................................................... 7

16、' 清除选区图片 ....................................................................................................... 7

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

18、' 清除选区软回车 ................................................................................................... 8

19' 合并选区段落 ........................................................................................................... 8

20、' 选区空格转硬回车 ............................................................................................... 9

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

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

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

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

25、选中的文本横向居中 ............................................................................................. 12

26、缩小字距 ................................................................................................................. 13

27、增大字距 ................................................................................................................. 13

28、缩小行距 ................................................................................................................. 14

29、增大行距 ................................................................................................................. 14

30、等高变宽 ................................................................................................................. 15

31、等高变窄 ................................................................................................................. 15

32、字表间距 ................................................................................................................. 15

33、纵向16开 ............................................................................................................... 16

34、插入页码 ................................................................................................................. 16

35、小写金额转大写金额 ............................................................................................. 17

二、 其它 ......................................................................................................................... 22

1.调整图片大小 ............................................................................................................. 22

2.转字体......................................................................................................................... 23

3.转文件格式 ................................................................................................................. 25

4、文件加密 ................................................................................................................... 26

1

5、字符替换 ................................................................................................................... 27

6、替换引号 ................................................................................................................... 27

7、打印为PDF格式文件 ............................................................................................. 28

8、朗读文本 ................................................................................................................... 28

9. 文献标号上标化 ........................................................................................................ 29

10. 箭头上方加文字 ...................................................................................................... 29

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

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

式一的代码 ..................................................................................................................... 30

13. 返回正文 .................................................................................................................. 31

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

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

16、统计修订的字数 ..................................................................................................... 32

17、快速提取脚注内容 ................................................................................................. 33

18、从任意页面编排页码 ............................................................................................. 33

19、批量实现缩放打印 ................................................................................................. 34

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

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

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

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

2

一、 修改word格式：

1、' 智能清除选区软回车（换行符）

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

With

.Text = "?^l"

. = "^&^p"

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = False

.MatchAllWordForms = False

.MatchSoundsLike = False

.MatchWildcards = True

End With

e Replace:=wdReplaceAll

With

.Text = "^1^l"

. = "^&^p"

End With

e Replace:=wdReplaceAll

With

.Text = "^l"

. = ""

End With

e Replace:=wdReplaceAll

End Sub

2、' 清除选区多余空段

Sub 清除选区多余空段()

With

.Text = "^p^p"

. = "^p"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

1

With

.Text = "^p^p^p"

. = "^p"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "^p^p^p"

. = "^p"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "^p^p"

. = "^p"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "^p^p"

. = "^p"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "^p^p^p"

. = "^p"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "^p "

. = "^p"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

2

.Text = "^p^p"

. = "^p"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "^p^p"

. = "^p"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

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

Sub 合并选区多余分段()

With

.Text = "，^p"

. = "，"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "、^p"

. = "、"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

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

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

With

.Text = " "

. = ""

3

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

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

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

With

.Text = " "

. = ""

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

6、' 清除选区1字空格

Sub 清除选区1字空格()

With

.Text = " "

. = ""

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

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

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

With

.Text = " "

. = ""

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

4

8、' 清除选区Tab

Sub 清除选区Tab()

With

.Text = vbTab

. = ""

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

9、' 增加选区空格

Sub 增加选区空格()

With

.Text = " "

. = " "

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

10、' 选区段首缩进0字

Sub 选区段首无缩进()

With

.Text = " "

. = ""

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With aphFormat

.LeftIndent = CentimetersToPoints(0)

.RightIndent = CentimetersToPoints(0)

.FirstLineIndent = CentimetersToPoints(0)

.CharacterUnitLeftIndent = 0

.CharacterUnitRightIndent = 0

5

'左缩进0字符

'右缩进0字符

'首行缩进点0公分

'左缩进单位0字符

'右缩进单位0字符

.CharacterUnitFirstLineIndent = 0

End With

With aphFormat

.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 aphFormat

.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 选区段首缩进转空格()

ParagraphBefore

Call 选区段首无缩进

With

.Text = "^p"

. = "^p "

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

6

With

.Text = " ^p"

. = ""

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

13、' 选区段后间距1行

Sub 选区段后间距1行()

ineIndent = CentimetersToPoints(0)

itAfter = 1

End Sub

14、' 选区段后间距1行

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

ineIndent = CentimetersToPoints(0)

itBefore = 0.5

itAfter = 0.5

End Sub

15、' 选区段后间距1行

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

ineIndent = CentimetersToPoints(0)

itBefore = 0

itAfter = 0

End Sub

16、' 清除选区图片

7

Sub 清除选区图片()

With

.Text = "^1"

. = ""

.MatchWildcards = True

End With

e Replace:=wdReplaceAll

End Sub

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

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

With

.Text = "^p"

. = "^l"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

18、' 清除选区软回车

Sub 清除选区软回车()

' With

.Text = "^l"

. = ""

.MatchWildcards = True

End With

e Replace:=wdReplaceAll

End Sub

19' 合并选区段落

Sub 合并选区段落()

With

.Text = " "

8

. = ""

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "^p"

. = "^l"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "^l"

. = ""

.MatchWildcards = True

End With

e Replace:=wdReplaceAll

'添加段落符号

End Sub

20、' 选区空格转硬回车

Sub 选区空格转硬回车()

With

.Text = " "

. = "^p"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

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

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

With

.Text = ","

. = "，"

.MatchWildcards = False

9

End With

e Replace:=wdReplaceAll

With

.Text = ";"

. = "；"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = ":"

. = "："

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "?"

. = "？"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "!"

. = "！"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "......"

. = "……"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "."

. = "。"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

10

End Sub

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

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

With

.Text = "，"

. = ","

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "；"

. = ";"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "："

. = ":"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "？"

. = "?"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "！"

. = "!"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "……"

11

. = "......"

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

With

.Text = "。"

. = "."

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

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

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

With

.Text = "。"

. = "."

.MatchWildcards = False

End With

e Replace:=wdReplaceAll

End Sub

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

Sub 标题1()

aphs(1).Style = ("标题 1")

ent = wdAlignParagraphCenter

End Sub

25、选中的文本横向居中

Sub 横向居中()

With

.Text = " "

. = ""

.MatchWildcards = False

12

End With

e Replace:=wdReplaceAll

With aphFormat

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

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

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

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

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

.CharacterUnitFirstLineIndent = 0

End With

With aphFormat

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

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

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

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

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

.CharacterUnitFirstLineIndent = 0

End With

ent = wdAlignParagraphCenter

End Sub

26、缩小字距

Sub 缩小字距()

Dim b

On Error Resume Next

ibility(wdSpacingInWholePoints) = False '不按点阵缩放

字距

If g = 9999999 Then '当字距不等时,此值为9999999

For b = 1 To '得到所选字符总数

ters(b).g = ters(b).g - 0.1 '

为每个字符更改字距

Next b

Else

g = g - 0.1

End If

End Sub

27、增大字距

13

Sub 增大字距()

On Error Resume Next

ibility(wdSpacingInWholePoints) = False '不按点阵缩放

字距

Dim b

If g = 9999999 Then '当字距不等时,此值为9999999

For b = 1 To '得到所选字符总数

ters(b).g = ters(b).g + 0.1

'为每个字符更改字距

Next b

Else

g = g + 0.1

End If

End Sub

28、缩小行距

Sub 缩小行距()

Dim b

On Error Resume Next

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

With aphFormat

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

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

End With

If acing = 9999999 Then

For b = 1 To

aphs(b).LineSpacing = aphs(b).LineSpacing *

0.95

Next b

Else

acing = acing *

0.95

End If

End Sub

29、增大行距

Sub 增大行距()

Dim b

On Error Resume Next

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

With aphFormat

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

14

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

End With

If acing = 9999999 Then '当段落间距不等时,此值为

9999999

For b = 1 To '得到所选段落总数

aphs(b).LineSpacing = aphs(b).LineSpacing *

1.05

Next b

Else

acing = acing *

1.05

End If

End Sub

30、等高变宽

Sub 等高变宽()

On Error Resume Next

g = g + 1

End Sub

31、等高变窄

Sub 等高变窄()

On Error Resume Next

g = g - 1

End Sub

32、字表间距

Sub 字表间距()

On Error Resume Next

ibility(wdAlignTablesRowByRow) = False

(1).Select

With s(wdBorderTop)

.LineStyle = wdLineStyleSingle

.LineWidth = wdLineWidth150pt

.Color = tBorderColor

End With

With s(wdBorderLeft)

.LineStyle = wdLineStyleSingle

.LineWidth = wdLineWidth150pt

.Color = tBorderColor

End With

15

With s(wdBorderBottom)

.LineStyle = wdLineStyleSingle

.LineWidth = wdLineWidth150pt

.Color = tBorderColor

End With

With s(wdBorderRight)

.LineStyle = wdLineStyleSingle

.LineWidth = wdLineWidth150pt

.Color = tBorderColor

End With

On Error GoTo a:

(1).ent = wdAlignRowCenter

alAlignment = wdCellAlignVerticalCenter

etweenColumns = 0

(1).AllowAutoFit = False

a:

If Err = 4605 Then

MsgBox "当前位置不在表格中,请重新定义。", vbInformation, "刘厚彬现在轻轻地告

诉你"

End If

End Sub

33、纵向16开

Sub 纵向16开()

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

).PageSetup '插入点之后

'With tup '整篇文档

With tup '本节

.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、插入页码

16

Sub 插入页码()

Dim fstpg As Byte

Dim mydialog As Dialog

Dim a As String

On Error Resume Next

fstpg = 1

eldCodes = False '隐藏窗口域代码

Set mydialog = Dialogs(wdDialogInsertPageNumbers)

If y = -1 Then '-2关闭；-1确定；0取消；1第一个按钮，

2第二个按钮，以此类推。

If age = False Then '判断首页是否打印页码

age = True

fstpg = False

End If

e

ew = wdSeekCurrentPageFooter

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

If $(, 1, 1) <> "—" Then

Unit:=wdLine

xt text:=" —"

ft Unit:=wdCharacter, Count:=5

xt text:="— "

terUnitRightIndent = 0.75

terUnitFirstLineIndent = 1.19

End If

If fstpg = False Then

age = False

e '首页不显示页码

End If

ew = wdSeekMainDocument

End If

End Sub

35、小写金额转大写金额

Sub 大写金额()

Dim BigNum, snum, i, mydata As DataObject

On Error GoTo e

Set mydata = New DataObject

BigNum = ""

snum =

If IsNumeric(snum) = False Then

mClipboard '从剪切板取值

17

'切换到页脚

snum = t(1)

End If

snum = ((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 + (cNum, ((snum, i, 1)) + 1, 1) +

(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, (cCha, i * 2 + 1, 2), (cCha, i + 26, 1))

Next i

End If

ght

xt text:=BigNum

End

e:

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

End Sub

36、’去掉空白行

Sub 去掉空白行()

y Unit:=wdStory

ormatting

ormatting

With

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

. = "^13"

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = False

.MatchAllWordForms = False

18

.MatchSoundsLike = False

.MatchWildcards = True

End With

e Replace:=wdReplaceAll

End Sub

37、查找替换

Sub 查找替换()

With

.ClearFormatting '清除格式设置

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

With .Replacement '替换条件

.ClearFormatting '清除格式设置

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

End With

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

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

End With

End Sub

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

Sub 格式设置()

'

' 格式设置 Macro

Updating = False

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

ormatting

ormatting

With

.Text = "^l"

. = "^p"

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

19

e Replace:=wdReplaceAll

'去除所有空行

Dim i As Paragraph, n As Integer

Updating = False

For Each i In aphs

If Len() = 1 Then

n = n + 1

End If

Next

Updating = True

'去除半角空格

ormatting

ormatting

With

.Text = " "

. = ""

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

e Replace:=wdReplaceAll

'去除全角空格

ormatting

ormatting

With

.Text = " "

. = ""

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

20

e Replace:=wdReplaceAll

'替换非标准引号为标准引号

ormatting

ormatting

With

.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

e Replace:=wdReplaceAll

'字母数字符号全角转半角 Macro

Dim qjsz, bjsz As String, iii As Integer '定义qjsz(全角数字)、bjsz(半角数字)为字符串型，iii

为整数型

qjsz = "０１２３４５６７８９ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗ

ｘｙｚＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ,./<>?;’:[]{}|=-+_)(

bjsz = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXY

Z，。／《》？；'：【】｛｝＼｜＝－＋＿）（

tory

For iii = 1 To 95 '循环10次

With

.Text = Mid(qjsz, iii, 1) 'mid函数：返回文本字符串中从指定位置开始的特定数目的字

符，每次取一个数字

. = Mid(bjsz, iii, 1) '将用于替换的相应位置的半角数字

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

.MatchWildcards = False

.Execute Replace:=wdReplaceAll '用半角符号替换全角符号

End With

Next iii

'修改小数点错误

ormatting

ormatting

With

.Text = "([0-9])。([0-9])"

. = "1.2"

.Forward = True

.Wrap = wdFindContinue

21

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = False

.MatchAllWordForms = False

.MatchSoundsLike = False

.MatchWildcards = True

End With

e Replace:=wdReplaceAll

'设置字号

tory '全选

ormatting '清除全文格式

= 14 '设置字号为14号

'设置行距

acingRule = wdLineSpaceExactly

acing = 25

ent = wdAlignParagraphJustify '设置文本为两端对齐

terUnitFirstLineIndent = 2 '设置段首缩进2字符

y Unit:=wdStory '移至文首

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

ormatting '清除首行格式

ent = wdAlignParagraphCenter '设置首行居中对齐

itBefore = 1 '设置首行段前间距1行

itAfter = 1 '设置首行段后间距1行

= "微软雅黑" '设置首行字体为“微软雅黑”

= 18 '设置首行字号为18号

= wdToggle '设置首行字形为加粗

Updating = True

End Sub

二、 其它

1.调整图片大小

Sub setpicsize() '设置图片大小

Dim n '图片个数

On Error Resume Next '忽略错误

For n = 1 To 'InlineShapes

类型图片

22

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

400px

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

300px

Next n

For n = 1 To 'Shapes类型图片

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

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

alog(msoFileDialogFilePicker)

With MyDialog

.Title = "请选择要处理的文档（可多选）"

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

23

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

为所有WORD文件

.AllowMultiSelect = True '允许多项选择

If .Show = -1 Then '确定

Updating = False

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

循环

Set Doc = (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

Updating = True

24

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_SOUCElib"

For i = 1 To 2124 '文件数2124

filename:=name & ".txt",

ConfirmConversions:=False, ReadOnly:= _

False, AddToRecentFiles:=False,

PasswordDocument:="", PasswordTemplate:= _

"", Revert:=False, WritePasswordDocument:="",

WritePasswordTemplate:="", _

Format:=wdOpenFormatAuto

25

filename:=name & ".txt",

FileFormat:= _

wdFormatTextLineBreaks,

Password:="", _

AddToRecentFiles:=True,

LockComments:=False,

WritePassword:="",

ReadOnlyRecommended:=False, _

EmbedTrueTypeFonts:=False,

SaveNativePictureFormat:=False, SaveFormsData _

:=False, SaveAsAOCELetter:=False

name = name + 1

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

Next i

End Sub

4、文件加密

sub mima（）

with activedocument

.password="123"

.writepassword="456"

26

end with

end sub

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

5、字符替换

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

With '在当前文档中进行查找

.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

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

.Text = """"

. = "前z"

.Execute Replace:=wdReplaceOne, Forward:=True

27

End With

Else

With '反之则将相应的引号替换为“后z”

.Text = """"

. = "后z"

.Execute Replace:=wdReplaceOne, Forward:=True

End With

End If

Next '进行下一对引号的替换

With

'以下代码将所有的“前z”替换为左引号

.Text = "前z"

. = "“"

.Execute Replace:=wdReplaceAll, Forward:=True

'以下代码将所有的“后z”替换为右引号

.Text = "后z"

. = "”"

.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

rawingObjects = True '打印图形对象

ActivePrinter = "Acrobat PDFWriter"

ut

c:

ActivePrinter = b

End Sub

8、朗读文本

Sub 朗读文本()

On Error Resume Next

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

(ion)

End Sub

28

9. 文献标号上标化

Sub 文献标号上标化()

'

' 参考文献上标化 Macro

' 宏在 2006-11-3 由 ***** 创建

'

y Unit:=wdStory

ormatting

With

.Superscript = True

End With

With

.Text = "[[０-９，0-9,～~－- ]@]"

. = ""

.MatchWildcards = True

End With

e Replace:=wdReplaceAll

ormatting

With

.Superscript = True

End With

With

.Text = "［[０-９，0-9,～~－- ]@］"

. = ""

.MatchWildcards = True

End With

e Replace:=wdReplaceAll

End Sub

10. 箭头上方加文字

Sub 箭头上方加文字()

'

' 箭头上方加文字 Macro

' 宏在 2008-4-16 由 ***** 创建

'

Range:=, Type:=wdFieldEmpty, _

PreserveFormatting:=False

ckspace

Unit:=wdCharacter, Count:=1

xt Text:="eq o(sdo2(──────────→),sup5(敲击Delete键

清除此段文字，改填所需文字，酌情增减箭头长度，最后同时按下shift和F9))"

ft Unit:=wdCharacter, Count:=2

29

ft Unit:=wdWord, Count:=25, Extend:=wdExtend ‘顾经宇的代码是26，

改成25更好

End Sub

11 添加参考文献格式一，参考文献在文档末尾以1． 2． 3． 格式

排列

Sub 添加参考文献格式一()

'

' 添加参考文献 Macro

' 宏在 2008-4-17 由 ***** 创建

'

= ("尾注引用")

xt Text:="[]"

ft Unit:=wdCharacter, Count:=1

With es

.StartingNumber = 1

.NumberStyle = wdNoteNumberStyleArabic

End With

Range:=, Reference:=""

ft Unit:=wdCharacter, Count:=1

ft Unit:=wdCharacter, Count:=1, Extend:=wdExtend

= ("默认段落字体")

ght Unit:=wdCharacter, Count:=1

Unit:=wdCharacter, Count:=1

xt Text:="． "

End Sub

12. 添加参考文献格式二，参考文献在文档末尾以[1] [2] [3] 格式排

列，修改自格式一的代码

Sub 添加参考文献格式二()

'

' 添加参考文献 Macro

' 宏在 2008-4-17 由 ***** 创建

'

= ("尾注引用")

xt Text:="[]"

ft Unit:=wdCharacter, Count:=1

With es

.StartingNumber = 1

30

.NumberStyle = wdNoteNumberStyleArabic

End With

Range:=, Reference:=""

ft Unit:=wdCharacter, Count:=1

ft Unit:=wdCharacter, Count:=1, Extend:=wdExtend

= ("默认段落字体")

ght Unit:=wdCharacter, Count:=1

Unit:=wdCharacter, Count:=1

xt Text:="] "

ft Unit:=wdCharacter + 2, Count:=1

xt Text:="["

End Sub

13. 返回正文

Sub 返回正文()

'返回正文 Macro

'宏在 2008-4-16 由 ***** 创建

'

If = wdPageView Or ActiveWindow. _

= wdOnlineView Or _

= wdPrintPreview Then

ew = wdSeekMainDocument

Else

(2).Close

End If

ght Unit:=wdCharacter, Count:=2

End Sub

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

Sub 引用编号()

'引用编号 Macro

'宏在 2008-4-16 由 ***** 创建

'

cript = wdToggle

xt Text:="[]"

ft Unit:=wdCharacter, Count:=1

With Dialogs(wdDialogInsertCrossReference)

.InsertAsHyperlink = True

.Show

End With

ght Unit:=wdCharacter, Count:=1

cript = wdToggle

31

End Sub

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

Sub 查找被删编号()

'要删除某个参考文献，应该在原始引用处删除引用，这样可以一并删除参考文献，而不是

在文档末尾文献列表处删除

tory

ormatting

With

.Text = "错误！未定义书签。"

End With

e

ft Unit:=wdCharacter, Count:=1

ght 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 ons

If = wdRevisionInsert Then

For Each Wd In

c1 = c1 + IIf(Wd Like "[一-龥]*", , 1)

Next

n1 = n1 + 1

a = a & & vbTab

ElseIf = wdRevisionDelete Then

For Each Wd In

c2 = c2 + IIf(Wd Like "[一-龥]*", , 1)

Next

n2 = n2 + 1

b = b & & vbTab

End If

Next

MsgBox "增加内容" & n1 & "处共" & c1 & "字；删除内容" &

n2 & "处共" & c2 & "字。"

End Sub

32

17、快速提取脚注内容

Sub test()

Dim oFootNote As Footnote, myRange As Range

Dim BeforeName As String, BeforeSize As Single

On Error Resume Next

Updating = False

For Each oFootNote In tes

With oFootNote

Set myRange = (., .)

.

With myRange

.Text = "(JZ: )"

BeforeName = .

BeforeSize = .

ge .Start + 4, .Start + 4

.Paste

. = BeforeName

. = BeforeSize

End With

End With

Next

Updating = True

End Sub

18、从任意页面编排页码

Sub test()

myPath = "H:temp"

y Unit:=wdStory

Set myRange =

curpage = 0

Updating = False

Do

prepage = curpage

pagenum = pagenum + 1

Set myRange = xt(What:=wdGoToPage)

curpage =

endpage =

If curpage = prepage Then _

endpage =

(prepage, endpage).Copy

With

33

.

.SaveAs myPath & "Page" & pagenum & ".doc"

.Close

End With

If curpage = prepage Then Exit Do

Loop

Updating = True

End Sub

19、批量实现缩放打印

Sub test()

Updating = False

With arch

.LookIn = "h:Downloadstemp5"

.FileType = msoFileTypeWordDocuments

If .Execute > 0 Then

Fori =

FileName:=.FoundFiles(i)

utPrintZoomPaperWidth:=10433,

PrintZoomPaperHeight:=14742

False

Next i

End If

End With

Updating = True

34

End Sub

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

Sub macro1()

Dim s() As String, temp As String, i As Long

VBAs = Split(t, 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

= Join(s, Chr(13) & Chr(13))

End Sub

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

Sub text()

n = 0

For Eachs In

Anchor:=ange, _

Address:=""

n=n+1

35

Next

MsgBox "共替换" &n& "个图片！"

End Sub

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

Sub test()

Dim m As Integer, n As Page

m = ation(wdNumberOfPagesInDocument)

y 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

pectRatio = msoTrue

= 4 * 28.35

Next

36

For Each InlineShp In .InlineShapes

pectRatio = msoTrue

= 4 * 28.35

For Each Bder In s

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 =

With myRange

If . = 0 Then

MsgBox "您所选的内容中没有域代码!", vbInformation

Exit Sub

Else

.

.eFieldCodes = True

.eHiddenText = True

myCodes = .Text

myCodes = e(myCodes, Chr(19), "{")

myCodes = e(myCodes, Chr(21), "}")

.SetRange .End, .End

.InsertAfter myCodes '"注意,""{}""是由Ctrl+F9组合键自动插入的域标志! " &

vbLf & "域代码:" & myCodes

. = "Tahoma"

. = 11

.Cut

End If

End With

End Sub

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

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

37

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

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

们。

review

rintPreview

= wdNormalView

End Sub

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

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

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

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

review

rintPreview

= wdNormalView

= wdPrintView

End Sub

'27、彻底删除页眉页脚

Sub 彻底删除页眉页脚()

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

'①konggs版主于2005-7-26 20:38、2005-7-27 08:51发表的帖子，

'链接为/?tid=112178；

'②守柔版主于2005-7-27年发表于站内的文章《Word中鲜为人知的三招》，

'链接为/Article/?ArticleID=439。

'此宏不足处在于：

'①刪除页眉页脚后不能再恢复；

'②本地文档进行删除操作后不保存退出的话，会在下次启动Word时出现文档恢复窗格。

Dim w, y As String

Updating = False

Set w = ojectItems(2)

If = 2 Then

If = "" Then

38

= ""

hProject

hDocument

If Like "*.doc" Then

MsgBox "本文档页眉页脚已彻底清除，请及时保存。" & Chr(13) & _

"若退出本地文档时未保存，重新启动Word时将出现恢复窗格。

", vbExclamation, "ExcelHome"

Else

Exit Sub

End If

End If

Else

MsgBox "本文档当前未设置页眉页脚，不需要进行删除操作。", vbOKOnly,

"ExcelHome"

End If

Updating = True

End Sub

'28、切换纵横向页面

Sub 切换纵横向页面()

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

If ation = wdOrientLandscape Then

ation = wdOrientPortrait

Else

ation = wdOrientLandscape

End If

End Sub

39