|
Word宏代码集锦 11 添加参考文献格式一，参考文献在文档末尾以1． 2． 3． 格式排列 12. 添加参考文献格式二，参考文献在文档末尾以[1] [2] [3]格式排列，修改自格式一的代码 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 = "０１２３４５６７８９ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ,./<>?;’:[]{}|=-+_)( 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,～~－- ]@]" .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,～~－- ]@］" .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() 17、快速提取脚注内容 Sub test() 18、从任意页面编排页码 Sub test() 19、批量实现缩放打印 Subtest() 20、对文档内容进行顺序排列 Submacro1() 21、替换Word文档插图的超链接 Sub text() 22、为文档的每页添加固定内容 Subtest() 23、批量实现图片的等比例缩 Sub test() 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./viewthread.php?tid=112178； '②守柔版主于2005-7-27年发表于站内的文章《Word中鲜为人知的三招》， '链接为http://www./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 |
|
|
来自： 自扶馆 > 《WORD 全选 宏》
