Word宏代码集锦
11 添加参考文献格式一,参考文献在文档末尾以1. 2. 3. 格式排列
12. 添加参考文献格式二,参考文献在文档末尾以[1] [2] [3]格式排列,修改自格式一的代码
一、 修改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
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^1^l"
.Replacement.Text = "^&^p"
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^l"
.Replacement.Text = ""
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
2、' 清除选区多余空段
Sub清除选区多余空段()
WithSelection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^p^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^p^p^p"
.Replacement.Text = "^p"
.MatchWildcards= False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^p^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^p "
.Replacement.Text = "^p"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
3、' 合并选区中“,”结束的多余分段
Sub合并选区多余分段()
WithSelection.Find
.Text = ",^p"
.Replacement.Text = ","
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "、^p"
.Replacement.Text= "、"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
4、' 清除选区单字节空格
Sub清除选区单字节空格()
WithSelection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
5、' 清除选区单字节空格
Sub清除选区2单字节空格()
WithSelection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
6、' 清除选区1字空格
Sub清除选区1字空格()
WithSelection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
7、' 清除选区段首2字空格
Sub清除选区段首2字空格()
WithSelection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
8、' 清除选区Tab
Sub清除选区Tab()
WithSelection.Find
.Text = vbTab
.Replacement.Text = ""
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
9、' 增加选区空格
Sub增加选区空格()
WithSelection.Find
.Text = " "
.Replacement.Text = " "
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
10、' 选区段首缩进0字
Sub选区段首无缩进()
WithSelection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.ParagraphFormat
.LeftIndent =CentimetersToPoints(0) '左缩进0字符
.RightIndent =CentimetersToPoints(0) '右缩进0字符
.FirstLineIndent =CentimetersToPoints(0) '首行缩进点0公分
.CharacterUnitLeftIndent =0 '左缩进单位0字符
.CharacterUnitRightIndent=0 '右缩进单位0字符
.CharacterUnitFirstLineIndent = 0
EndWith
WithSelection.ParagraphFormat
.LeftIndent =CentimetersToPoints(0) '左缩进1字符
.RightIndent =CentimetersToPoints(0) '右缩进2字符
.FirstLineIndent =CentimetersToPoints(0) '首行缩进点0.35公分
.CharacterUnitLeftIndent =0 '左缩进单位0字符
.CharacterUnitRightIndent=0 '右缩进单位0字符
.CharacterUnitFirstLineIndent = 0
EndWith
EndSub
11、' 选区段首缩进:2字
Sub选区段首缩进2字()
WithSelection.ParagraphFormat
.LeftIndent =CentimetersToPoints(0) '左缩进1字符
.RightIndent =CentimetersToPoints(0) '右缩进2字符
.FirstLineIndent =CentimetersToPoints(0.35) '首行缩进点单位公分
.CharacterUnitLeftIndent =0 '左缩进单位0字符
.CharacterUnitRightIndent=0 '右缩进单位0字符
.CharacterUnitFirstLineIndent = 2
EndWith
EndSub
12、' 选区段首缩进转空格—已完美
Sub选区段首缩进转空格()
Selection.InsertParagraphBefore
Call 选区段首无缩进
WithSelection.Find
.Text = "^p"
.Replacement.Text = "^p "
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Delete
WithSelection.Find
.Text = " ^p"
.Replacement.Text = ""
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
13、' 选区段后间距1行
Sub选区段后间距1行()
Selection.ParagraphFormat.FirstLineIndent =CentimetersToPoints(0)
Selection.ParagraphFormat.LineUnitAfter = 1
EndSub
14、' 选区段后间距1行
Sub选区段前段后间距半行()
Selection.ParagraphFormat.FirstLineIndent =CentimetersToPoints(0)
Selection.ParagraphFormat.LineUnitBefore = 0.5
Selection.ParagraphFormat.LineUnitAfter = 0.5
EndSub
15、' 选区段后间距1行
Sub选区段前段后无间距()
Selection.ParagraphFormat.FirstLineIndent =CentimetersToPoints(0)
Selection.ParagraphFormat.LineUnitBefore = 0
Selection.ParagraphFormat.LineUnitAfter = 0
EndSub
16、' 清除选区图片
Sub清除选区图片()
WithSelection.Find
.Text = "^1"
.Replacement.Text = ""
.MatchWildcards = True
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
17、' 选区硬回车转软回车
Sub选区硬回车转软回车()
WithSelection.Find
.Text = "^p"
.Replacement.Text = "^l"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
18、' 清除选区软回车
Sub清除选区软回车()
' WithSelection.Find
.Text = "^l"
.Replacement.Text = ""
.MatchWildcards = True
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
19' 合并选区段落
Sub合并选区段落()
WithSelection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^p"
.Replacement.Text = "^l"
.MatchWildcards =False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "^l"
.Replacement.Text = ""
.MatchWildcards = True
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Paragraphs.Add '添加段落符号
End Sub
20、' 选区空格转硬回车
Sub选区空格转硬回车()
WithSelection.Find
.Text = " "
.Replacement.Text = "^p"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
21、' 选区标点半角转全角
Sub选区标点半角转全角()
WithSelection.Find
.Text = ","
.Replacement.Text = ","
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = ";"
.Replacement.Text = ";"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = ":"
.Replacement.Text = ":"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "?"
.Replacement.Text = "?"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text= "!"
.Replacement.Text = "!"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "......"
.Replacement.Text = "……"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "."
.Replacement.Text = "。"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
22、' 选区标点全角转半角
Sub 选区标点全角转半角()
WithSelection.Find
.Text = ","
.Replacement.Text = ","
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = ";"
.Replacement.Text= ";"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = ":"
.Replacement.Text = ":"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "?"
.Replacement.Text = "?"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "!"
.Replacement.Text = "!"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "……"
.Replacement.Text = "......"
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.Find
.Text = "。"
.Replacement.Text = "."
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
23、' 选区中文句号转半角
Sub选区中文句号转半角()
WithSelection.Find
.Text = "。"
.Replacement.Text = "."
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
EndSub
24、’把文档第一段设置为标题1的格式
Sub标题1()
ActiveDocument.Paragraphs(1).Style =ActiveDocument.Styles("标题 1")
Selection.ParagraphFormat.Alignment =wdAlignParagraphCenter
EndSub
25、选中的文本横向居中
Sub横向居中()
WithSelection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
WithSelection.ParagraphFormat
.LeftIndent =CentimetersToPoints(0) '左缩进0字符
.RightIndent =CentimetersToPoints(0) '右缩进0字符
.FirstLineIndent =CentimetersToPoints(0) '首行缩进点0公分
.CharacterUnitLeftIndent =0 '左缩进单位0字符
.CharacterUnitRightIndent=0 '右缩进单位0字符
.CharacterUnitFirstLineIndent = 0
EndWith
WithSelection.ParagraphFormat
.LeftIndent =CentimetersToPoints(0) '左缩进1字符
.RightIndent =CentimetersToPoints(0) '右缩进2字符
.FirstLineIndent =CentimetersToPoints(0) '首行缩进点0.35公分
.CharacterUnitLeftIndent =0 '左缩进单位0字符
.CharacterUnitRightIndent=0 '右缩进单位0字符
.CharacterUnitFirstLineIndent = 0
EndWith
Selection.ParagraphFormat.Alignment =wdAlignParagraphCenter
EndSub
26、缩小字距
Sub缩小字距()
Dimb
OnError Resume Next
ActiveDocument.Compatibility(wdSpacingInWholePoints) =False '不按点阵缩放字距
IfSelection.Font.Spacing = 9999999Then '当字距不等时,此值为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
EndIf
EndSub
27、增大字距
Sub增大字距()
OnError Resume Next
ActiveDocument.Compatibility(wdSpacingInWholePoints) =False '不按点阵缩放字距
Dimb
IfSelection.Font.Spacing = 9999999Then '当字距不等时,此值为9999999
For b = 1 To Selection.Characters.Count '得到所选字符总数
Selection.Characters(b).Font.Spacing =Selection.Characters(b).Font.Spacing + 0.1 '为每个字符更改字距
Nextb
Else
Selection.Font.Spacing = Selection.Font.Spacing + 0.1
EndIf
EndSub
28、缩小行距
Sub缩小行距()
Dimb
OnError Resume Next
StatusBar = "老刘郑重提示:该命令会取消行自动对齐到行网格!"
WithSelection.ParagraphFormat
.AutoAdjustRightIndent =False '不自动调整右缩进
.DisableLineHeightGrid =True '不自动对齐行网格
EndWith
IfSelection.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
EndIf
EndSub
29、增大行距
Sub增大行距()
Dimb
OnError Resume Next
StatusBar = "老刘郑重提示:该命令会取消行自动对齐到行网格!"
WithSelection.ParagraphFormat
.AutoAdjustRightIndent =False '不自动调整右缩进
.DisableLineHeightGrid =True '不自动对齐行网格
EndWith
IfSelection.ParagraphFormat.LineSpacing = 9999999Then '当段落间距不等时,此值为9999999
For b = 1 ToSelection.Paragraphs.Count '得到所选段落总数
Selection.Paragraphs(b).LineSpacing =Selection.Paragraphs(b).LineSpacing * 1.05
Next b
Else
Selection.ParagraphFormat.LineSpacing =Selection.ParagraphFormat.LineSpacing * 1.05
EndIf
EndSub
30、等高变宽
Sub等高变宽()
OnError Resume Next
Selection.Font.Scaling = Selection.Font.Scaling + 1
EndSub
31、等高变窄
Sub等高变窄()
OnError Resume Next
Selection.Font.Scaling = Selection.Font.Scaling - 1
EndSub
32、字表间距
Sub字表间距()
OnError Resume Next
ActiveDocument.Compatibility(wdAlignTablesRowByRow) =False
Selection.Tables(1).Select
WithSelection.Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
EndWith
WithSelection.Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
EndWith
WithSelection.Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
EndWith
WithSelection.Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
EndWith
OnError GoTo a:
Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
Selection.Cells.VerticalAlignment =wdCellAlignVerticalCenter
Selection.Rows.SpaceBetweenColumns = 0
Selection.Tables(1).AllowAutoFit = False
a:
IfErr = 4605 Then
MsgBox "当前位置不在表格中,请重新定义。", vbInformation, "刘厚彬现在轻轻地告诉你"
EndIf
EndSub
33、纵向16开
Sub纵向16开()
' WithActiveDocument.Range(Start:=Selection.Start, End:=ActiveDocument._
Content.End).PageSetup '插入点之后
'WithActiveDocument.PageSetup '整篇文档
WithSelection.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
EndWith
EndSub
34、插入页码
Sub插入页码()
Dimfstpg As Byte
Dimmydialog As Dialog
Dima As String
OnError Resume Next
fstpg = 1
ActiveWindow.View.ShowFieldCodes = False '隐藏窗口域代码
Setmydialog = Dialogs(wdDialogInsertPageNumbers)
Ifmydialog.Display = -1Then '-2关闭;-1确定;0取消;1第一个按钮,2第二个按钮,以此类推。
If mydialog.firstpage = FalseThen '判断首页是否打印页码
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
EndIf
EndSub
35、小写金额转大写金额
Sub大写金额()
DimBigNum, snum, i, mydata As DataObject
On ErrorGoTo e
Set mydata= New DataObject
BigNum =""
snum =Selection.text
IfIsNumeric(snum) = False Then
mydata.GetFromClipboard '从剪切板取值
snum= mydata.GetText(1)
EndIf
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.TypeTexttext:=BigNum
End
e:
MsgBox"你输入数字错误或太大!请重新输入。", vbExclamation + vbOKOnly, "提示"
EndSub
36、’去掉空白行
Sub去掉空白行()
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
WithSelection.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
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
Application.GoBack
EndSub
37、查找替换
Sub查找替换()
WithActiveDocument.Content.Find
.ClearFormatting '清除格式设置
.Font.Name = "新宋体" '查找的字体格式
With.Replacement '替换条件
.ClearFormatting '清除格式设置
.Font.Name = "黑体" '替换成黑体
End With
.Execute findtext:="", ReplaceWith:="", Format:=True, _
Replace:=wdReplaceAll '是格式替换,全部替换
EndWith
EndSub
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 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ,./<>?;’:[]{}|=-+_)(
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 ResumeNext '忽略错误
For n = 1 ToActiveDocument.InlineShapes.Count 'InlineShapes类型图片
ActiveDocument.InlineShapes(n).Height = 400'设置图片高度为400px
ActiveDocument.InlineShapes(n).Width = 300'设置图片宽度300px
Nextn
For n = 1 ToActiveDocument.Shapes.Count 'Shapes类型图片
ActiveDocument.Shapes(n).Height = 400 '设置图片高度为 400px
ActiveDocument.Shapes(n).Width = 300 '设置图片宽度 300px
Nextn
EndSub
2.转字体
Sub批量设置小5号字体() '此代码为指定文件夹中所有选取的WORD文件的进行格式设置
Dim MyDialog AsFileDialog, vrtSelectedItem As Variant, Doc As Document
' On ErrorResume Next '忽略错误
'定义一个文件夹选取对话框
Set MyDialog =Application.FileDialog(msoFileDialogFilePicker)
WithMyDialog
.Title ="请选择要处理的文档(可多选)"
.Filters.Clear'清除所有文件筛选器中的项目
.Filters.Add"所有WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择
If .Show = -1Then '确定
Application.ScreenUpdating = False
For EachvrtSelectedItem In .SelectedItems '在所有选取项目中循环
Set Doc =Documents.Open(FileName:=vrtSelectedItem,Visible:=False)
WithDoc
With.Content
With.Font
' .NameFarEast ="宋体" '中文字体,已禁用
' .NameAscii ="Times New Roman" '英文字体,已禁用
.Size =9
EndWith
EndWith
.CloseTrue
EndWith
Next
Application.ScreenUpdating = True
EndIf
EndWith
MsgBox"批量设置完毕!", vbInformation
EndSub
3.转文件格式
SubMacro1()
' Macro1Macro
'宏在 01-10-31录制
'
Dimname AsString '文件名
name= "01"
ChangeFileOpenDirectory "E:VB_SOUCElib"
Fori = 1 To2124 '文件数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
Nexti
EndSub
4、文件加密
sub mima()
with activedocument
.password="123"
.writepassword="456"
end with
endsub
‘要注意的方面:第三行是打开权限、第四行是修改权限。
5、字符替换
Sub字符替换()'宏名称,可修改为其他字符
With ActiveDocument.Content.Find'在当前文档中进行查找
.Text = "其它"'被替换的字符
.Replacement.Text = "其他"'替换的字符
.Execute Replace:=wdReplaceAll, Forward:=True'替换全部
End With
EndSub
6、替换引号
Sub替换引号()
Dim CountxAs Integer, i As Integer, Sh As Byte '声明变量
'以下代码统计出文中的引号数目(包括""“”)
Countx =0
On ErrorResume Next
WithActiveDocument.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'如果引号不配对,则退出宏
EndIf
EndWith
For i = 1To Countx
Sh = i Mod2 '求i值除以2的余数
If Sh<> 0 Then '如果余数不等于0(即为奇数),则将相应的引号替'换为“前z”
WithActiveDocument.Content.Find
.Text =""""
.Replacement.Text = "前z"
.ExecuteReplace:=wdReplaceOne, Forward:=True
EndWith
Else
WithActiveDocument.Content.Find '反之则将相应的引号替换为“后z”
.Text =""""
.Replacement.Text = "后z"
.ExecuteReplace:=wdReplaceOne, Forward:=True
EndWith
EndIf
Next'进行下一对引号的替换
WithActiveDocument.Content.Find
'以下代码将所有的“前z”替换为左引号
.Text ="前z"
.Replacement.Text = "“"
.ExecuteReplace:=wdReplaceAll, Forward:=True
'以下代码将所有的“后z”替换为右引号
.Text ="后z"
.Replacement.Text = "”"
.ExecuteReplace:=wdReplaceAll, Forward:=True
EndWith
EndSub
7、打印为PDF格式文件
Sub打印为PDF格式文件()
On ErrorGoTo c:
Dim a AsBalloon
Dim b AsString
b =ActivePrinter
Options.PrintDrawingObjects = True '打印图形对象
ActivePrinter = "Acrobat PDFWriter"
ActiveDocument.PrintOut
c:
ActivePrinter = b
EndSub
8、朗读文本
Sub朗读文本()
OnError Resume Next
StatusBar = "老刘郑重提示:执行该命令后文本如果未朗读完将不能进行其他操作!"
Excel.Application.Speech.Speak (ActiveWindow.Selection)
EndSub
9.文献标号上标化
Sub文献标号上标化()
'
'参考文献上标化 Macro
'宏在 2006-11-3 由 *****创建
'
Selection.HomeKey Unit:=wdStory
Selection.Find.Replacement.ClearFormatting
WithSelection.Find.Replacement.Font
.Superscript = True
EndWith
WithSelection.Find
.Text = "[[0-9,0-9,~~-- ]@]"
.Replacement.Text = ""
.MatchWildcards = True
EndWith
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Replacement.ClearFormatting
WithSelection.Find.Replacement.Font
.Superscript = True
EndWith
WithSelection.Find
.Text = "[[0-9,0-9,~~-- ]@]"
.Replacement.Text = ""
.MatchWildcards = True
EndWith
Selection.Find.ExecuteReplace:=wdReplaceAll
EndSub
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(sdo2(──────────→),sup5(敲击Delete键清除此段文字,改填所需文字,酌情增减箭头长度,最后同时按下shift和F9))"
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdWord, Count:=25, Extend:=wdExtend‘顾经宇的代码是26,改成25更好
EndSub
11添加参考文献格式一,参考文献在文档末尾以1.2. 3. 格式排列
Sub添加参考文献格式一()
'
'添加参考文献 Macro
'宏在 2008-4-17 由 *****创建
'
Selection.Style = ActiveDocument.Styles("尾注引用")
Selection.TypeText Text:="[]"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
WithActiveDocument.Endnotes
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
EndWith
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:=". "
EndSub
12.添加参考文献格式二,参考文献在文档末尾以[1] [2] [3]格式排列,修改自格式一的代码
Sub添加参考文献格式二()
'
'添加参考文献 Macro
'宏在 2008-4-17 由 *****创建
'
Selection.Style = ActiveDocument.Styles("尾注引用")
Selection.TypeText Text:="[]"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
WithActiveDocument.Endnotes
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
EndWith
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.TypeTextText:="["
EndSub
13.返回正文
Sub返回正文()
'返回正文 Macro
'宏在 2008-4-16由 *****创建
'
IfActiveWindow.ActivePane.View.Type = wdPageView Or ActiveWindow._
ActivePane.View.Type = wdOnlineView OrActiveWindow.ActivePane.View.Type _
= wdPrintPreview Then
ActiveWindow.View.SeekView = wdSeekMainDocument
Else
ActiveWindow.Panes(2).Close
EndIf
Selection.MoveRight Unit:=wdCharacter, Count:=2
EndSub
14.再次引用已有参考文献
Sub引用编号()
'引用编号 Macro
'宏在 2008-4-16由 *****创建
'
Selection.Font.Superscript = wdToggle
Selection.TypeText Text:="[]"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
WithDialogs(wdDialogInsertCrossReference)
.InsertAsHyperlink = True
.Show
EndWith
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Font.Superscript = wdToggle
EndSub
15.查找被删参考文献遗留引用,
Sub查找被删编号()
'要删除某个参考文献,应该在原始引用处删除引用,这样可以一并删除参考文献,而不是在文档末尾文献列表处删除
Selection.WholeStory
Selection.Fields.Update
Selection.Find.ClearFormatting
WithSelection.Find
.Text = "错误!未定义书签。"
EndWith
Selection.Find.Execute
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1,Extend:=wdExtend
EndSub
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、批量实现缩放打印
Subtest()
Application.ScreenUpdating = False
With Application.FileSearch
.LookIn = "h:Downloadstemp5"
.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、对文档内容进行顺序排列
Submacro1()
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、为文档的每页添加固定内容
Subtest()
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提取域代码()
DimmyRange As Range, myCodes As String
SetmyRange = Selection.Range
WithmyRange
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
EndWith
EndSub
25、'完美显示图片表格的普通视图
Sub完美显示图片表格的普通视图()
'此宏为雨雪霏霏特别奉献的小偏方,欢迎各位朋友测试。
'如果文档中的嵌入式图片、表格显示迟滞、错位,运行此宏,将在普通视图下完美显示它们。
ActiveDocument.PrintPreview
ActiveDocument.ClosePrintPreview
ActiveWindow.View.Type = wdNormalView
EndSub
'26、完美显示图片表格的页面视图
Sub完美显示图片表格的页面视图()
'此宏为雨雪霏霏特别奉献的小偏方,欢迎各位朋友测试。
'如果文档中的各种图片、表格显示迟滞、错位,运行此宏,将在页面视图下完美显示它们。
ActiveDocument.PrintPreview
ActiveDocument.ClosePrintPreview
ActiveWindow.View.Type = wdNormalView
ActiveWindow.View.Type = wdPrintView
EndSub
'27、彻底删除页眉页脚
Sub彻底删除页眉页脚()
'此宏为雨雪霏霏试写。思路来自:
'①konggs版主于2005-7-2620:38、2005-7-27 08:51发表的帖子,
'链接为http://club.excelhome.net/viewthread.php?tid=112178;
'②守柔版主于2005-7-27年发表于站内的文章《Word中鲜为人知的三招》,
'链接为http://www.excelhome.cn/Article/ShowArticle.asp?ArticleID=439。
'此宏不足处在于:
'①刪除页眉页脚后不能再恢复;
'②本地文档进行删除操作后不保存退出的话,会在下次启动Word时出现文档恢复窗格。
Dimw, y As String
Application.ScreenUpdating = False
Setw = ActiveDocument.HTMLProject.HTMLProjectItems(2)
IfActiveDocument.HTMLProject.HTMLProjectItems.Count = 2Then
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"
EndIf
Application.ScreenUpdating = True
EndSub
'28、切换纵横向页面
Sub切换纵横向页面()
'在"纵向页面"与"横向页面"间切换。
IfActiveDocument.PageSetup.Orientation = wdOrientLandscapeThen
ActiveDocument.PageSetup.Orientation = wdOrientPortrait
Else
ActiveDocument.PageSetup.Orientation = wdOrientLandscape
EndIf
EndSub
联系客服