一、
修改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 i As Paragraph, n As Integer
Application.ScreenUpdating = False
For Each i In ActiveDocument.Paragraphs
If Len(i.Range) = 1 Then
i.Range.Delete
n = n + 1
End If
Next
Application.ScreenUpdating = True
'去除半角空格
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " "
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'去除全角空格
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " "
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'替换非标准引号为标准引号
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = """(*)"""
.Replacement.Text = ChrW(8220) & "\1" & ChrW(8221)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'字母数字符号全角转半角 Macro
Dim qjsz, bjsz As String, iii As Integer '定义qjsz(全角数字)、bjsz(半角数字)为字符串型，iii为整数型
qjsz = "０１２３４５６７８９ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ,./<>?;’:[]{}\|=-+_)(
bjsz = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ，。／《》？；'：【】｛｝＼｜＝－＋＿）（
Selection.WholeStory
For iii = 1 To 95 '循环10次
With Selection.Find
.Text = Mid(qjsz, iii, 1) 'mid函数：返回文本字符串中从指定位置开始的特定数目的字符，每次取一个数字
.Replacement.Text = Mid(bjsz, iii, 1) '将用于替换的相应位置的半角数字
.Format = False '保留替换前的字符格式
.MatchWildcards = False
.Execute Replace:=wdReplaceAll '用半角符号替换全角符号
End With
Next iii
'修改小数点错误
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([0-9])。([0-9])"
.Replacement.Text = "\1.\2"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'设置字号
Selection.WholeStory '全选
Selection.ClearFormatting '清除全文格式
Selection.Font.Size = 14 '设置字号为14号
'设置行距
Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
Selection.ParagraphFormat.LineSpacing = 25
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify '设置文本为两端对齐
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 2 '设置段首缩进2字符
Selection.HomeKey Unit:=wdStory '移至文首
Selection.EndKey Unit:=wdLine, Extend:=wdExtend '选中首行
Selection.ClearFormatting '清除首行格式
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '设置首行居中对齐
Selection.ParagraphFormat.LineUnitBefore = 1 '设置首行段前间距1行
Selection.ParagraphFormat.LineUnitAfter = 1 '设置首行段后间距1行
Selection.Font.Name = "微软雅黑" '设置首行字体为“微软雅黑”
Selection.Font.Size = 18 '设置首行字号为18号
Selection.Font.Bold = wdToggle '设置首行字形为加粗
Application.ScreenUpdating = True
End Sub
二、
其它
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 = "\[[０-９，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 由 *****
创建
'
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty,
_
PreserveFormatting:=False
Selection.TypeBackspace
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="eq \o(\s\do2(──────────→),\s\up5(敲击Delete键清除此段文字，改填所需文字，酌情增减箭头长度，最后同时按下shift和F9))"
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdWord, Count:=25, Extend:=wdExtend
‘顾经宇的代码是26，改成25更好
End
Sub
11
添加参考文献格式一，参考文献在文档末尾以1．2． 3． 格式排列
Sub
添加参考文献格式一()
'
'
添加参考文献 Macro
'
宏在 2008-4-17 由 *****
创建
'
Selection.Style = ActiveDocument.Styles("尾注引用")
Selection.TypeText Text:="[]"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With
ActiveDocument.Endnotes
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
End
With
ActiveDocument.Endnotes.Add Range:=Selection.Range,
Reference:=""
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1,
Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("默认段落字体")
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="． "
End
Sub
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:38、2005-7-27 08:51发表的帖子，
'链接为http://club./viewthread.php?tid=112178；
'②守柔版主于2005-7-27年发表于站内的文章《Word中鲜为人知的三招》，
'链接为http://www./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
|
