利用vba排版1.docx
《利用vba排版1.docx》由会员分享,可在线阅读,更多相关《利用vba排版1.docx(14页珍藏版)》请在冰豆网上搜索。
![利用vba排版1.docx](https://file1.bdocx.com/fileroot1/2022-12/14/2d762c34-7c48-4720-b12d-9f01dafc0147/2d762c34-7c48-4720-b12d-9f01dafc01471.gif)
利用vba排版1
目录
目录
目录1
一.使用VBA处理表格2
实例1:
将每个表格在文档中的以页面为基准居中对齐2
实例2:
将每个表格中的所有文本在单元格中自动居中对齐2
实例3:
删除文档中的所有表格3
实例4:
删除文档中的所有表格包含的空行3
实例5:
在表格第一列的每个单元格中插入指定的图片4
实例6:
自动将文档中的每个表格上方的标题汇总到新文档中5
实例7:
下面的代码一次性删除文档中所有表格的内外边框线和底纹效果6
实例8:
统一设置所有表格标题行的底纹颜色7
实例9:
统一设置所有表格的边框线样式8
二.使用VBA处理图片和图形对象10
实例1:
将所有图片的宽度统一设置为7厘米10
实例2:
快速为所有图片添加边框10
实例3:
下面的代码将文档中的所有图形填充色设置为红色11
实例4:
快速改变所有文本框中的字体颜色12
实例5:
批量删除文档中的所有图片12
实例6:
批量删除文档中的所有自选图形12
实例7:
批量删除文档中的所有文本框13
三.使用VBA处理文本13
实例1:
快速将指定内容提取到新文档中13
实例2:
批量设置不连续文本的格式15
实例3:
批量设置不连续段落的格式15
实例4:
快速删除文档中的所有空行16
一.使用VBA处理表格
实例1:
将每个表格在文档中的以页面为基准居中对齐
代码:
Sub将每个表格在文档中以页面为基准居中对齐()
DimtblAsTable
ForEachtblInActiveDocument.Tables
tbl.Rows.Alignment=wdAlignRowCenter
Nexttbl
Settbl=Nothing
EndSub
代码解析:
Table对象的Rows代表表格中的所有行。
Rows集合的Aligment属性用于设置整个表格在页面中的对齐方式:
wdAlignRowCenter居中(wdAlignRowLeft左对齐默认值,wdAlignRowRight右对齐)
实例2:
将每个表格中的所有文本在单元格中自动居中对齐
代码:
Sub将每个表格中的所有文本在单元格中自动居中对齐()
DimtblAsTable
ForEachtblInActiveDocument.Tables
tbl.Range.ParagraphFormat.Alignment=wdAlignParagraphCenter
Nexttbl
Settbl=Nothing
EndSub
代码解析:
Table对象的Range属性返回一个Range对象,代表一个表格在文档中的范围,使用Range对象的ParagphForment属性返回一个ParagraphFormat对象,用于设置表格内容的段落格式,ParagraphFormat对象的Aligement属性用于设置段落的对齐方式。
实例3:
删除文档中的所有表格
代码:
Sub删除文档中的所有表格()
DimtblAsTable
ForEachtblInActiveDocument.Tables
tbl.Delete
Nexttbl
Settbl=Nothing
EndSub
实例4:
删除文档中的所有表格包含的空行
代码:
Sub删除文档中的所有表格包含的空行()
DimtblAsTable
DimiRowAsInteger
ForEachtblInActiveDocument.Tables
ForiRow=tbl.Rows.CountTo1Step-1
IfLen(tbl.Rows(iRow).Range.Text)=(tbl.Columns.Count+1)*2Then
tbl.Rows(iRow).Delete
EndIf
NextiRow
Nexttbl
Settbl=Nothing
EndSub
代码解析:
表格中的一个空白单元格的长度为2=1个段落标记+1个表格边框线,每行最后一个单元格右侧,也就是位于表格外侧还有一个段落标记,该段落标记的长度也为2,因此,需要检测每行的总长度是否等于(表格列数+1)X2如果是则说明该行为空行,否则不是空行,Len(tbl.Rows(iRow).Range.Text)语句表示表格某行包含文本的总长度
实例5:
在表格第一列的每个单元格中插入指定的图片
自动插入6张照片第一个表格中的第一列的每个单元格中,6张图片和表格所属的文档位于同一个文件夹中。
代码:
Sub在表格第一列的每个单元格中插入指定的图片()
DimiAsInteger
DimvPicAsVariant
DimsFullNameAsString
DimtblAsTable
OnErrorResumeNext
Settbl=ActiveDocument.Tables
(1)
IfErr.Number<>0Then
MsgBox"请先创建一个不少于6行的表格"
ExitSub
EndIf
vPic=Array("辣椒","胡萝卜","西红柿","柚子","草莓","猕猴桃")
Fori=LBound(vPic)ToUBound(vPic)
sFullName=tbl.Parent.Path&"\"&vPic(i)&".jpg"
tbl.Columns
(1).Cells(i+1).Range.InlineShapes.AddPicturesFullName
Nexti
Settbl=Nothing
EndSub
实例6:
自动将文档中的每个表格上方的标题汇总到新文档中
如果文档中的每个表格上面的一行都包含一个标题,下面的代码将与每个表格相关的标题提取到一个新文档中
代码:
Sub自动将文档中的每个表格上方的标题汇总到新文档中()
DimtblAsTable
DimrngAsRange
DimsTitleAsString
ForEachtblInActiveDocument.Tables
Setrng=ActiveDocument.Range(tbl.Range.Start-1,tbl.Range.Start-1)
rng.Expand(wdParagraph)
sTitle=sTitle&rng.Text
Nexttbl
Documents.Add
Selection.Text=sTitle
Settbl=Nothing
Setrng=Nothing
EndSub
代码解析:
代码中声明了三个变量,tbl变量常用于遍历文档中的每一个表格,rng变量用于指定表格上方的标题范围,sTitle变量用于保存所有表格的标题,使用tbl变量遍历当前文档的每一个表格,在遍历每个单元格时,定义rng变量的范围为表格上方的段落的结尾位置,tbl.Range返回整个表格在文档中的范围,tbl.Range.Start返回表格的起始位置,将该值减1得到上一个段落结尾的位置,使用Range对象的Expand方法将rng变量中定义范围拓展到整个段落,然后将rng变量所表示的范围中的内容赋值给sTitle变量,在文档的每个表格中重复以上操作,最后将Stitle变量中保存的所有表格的标题写入新建的文档中。
实例7:
下面的代码一次性删除文档中所有表格的内外边框线和底纹效果
代码:
Sub删除打开的所有文档中所有表格的内外边框线和底纹效果()
DimdocAsDocument
DimtblAsTable
ForEachdocInDocuments
ForEachtblIndoc.Tables
tbl.Borders.OutsideLineStyle=wdLineStyleNone
tbl.Borders.InsideLineStyle=wdLineStyleNone
tbl.Rows
(1).Shading.BackgroundPatternColor=wdColorAutomatic
Nexttbl
Nextdoc
Setdoc=Nothing
Settbl=Nothing
EndSub
实例8:
统一设置所有表格标题行的底纹颜色
下面的代码自动将当前文档中的所有表格的标题行设置灰色底纹
代码:
Sub统一设置所有表格标题行的底纹颜色()
DimtblAsTable
ForEachtblInActiveDocument.Tables
tbl.Rows
(1).Shading.BackgroundPatternColor=wdColorGray15
Nexttbl
Settbl=Nothing
EndSub
代码解析:
Table对象的Ros属性代表表格中的所有行,使用Rows
(1)引用表格的第一行同时返回一个Row对象,然后使用Row对象的Shading属性设置表格的底纹效果。
本例中的wdColorGray15表示12%灰度,更多颜色:
常量值说明
wdColorAutomatic自动配色,默认值。
一般取决于文档的主题颜色
wdColorGray055%灰色底纹
wdColorGray1010%灰色底纹
wdColorGray12512.5%灰色底纹
wdColorGray37537.5%灰色底纹(其他量值改下数据就可以)
wdColorBlue蓝色
wdColorBlack黑色
wdColorBrown褐色
wdColorRed红色
wdColorGreen绿色
wdColorYellow黄色
wdColorViolet紫色(其他颜色一样设置,查下颜色的英语就可以)
实例9:
统一设置所有表格的边框线样式
下面代码将当前表格的外边框线设置为1.5磅宽的单线,将内边框线设置为1磅的点划线
代码:
Sub统一设置所有表格的边框线样式()
DimtblAsTable
ForEachtblInActiveDocument.Tables
Withtbl.Borders
.OutsideLineStyle=wdLineStyleSingle
.OutsideLineWidth=wdLineWidth150pt
.InsideLineStyle=wdLineStyleDashDot
.InsideLineWidth=wdLineWidth100pt
EndWith
Nexttbl
Settbl=Nothing
EndSub
代码解析:
设置表格边框线线型需要使用WdlineStyle常量,该常量的取值情况:
常量值说明
wdLineStyleNone无边框
wdLineStyleSingle单实线
wdLineStyleDouble双实线
wdLineStyleTriple三条细实线
wdLineStylesingleWavy波浪型单实线
wdLineStyleDot点
wdLineStyleDashDot划线后跟单个点
wdLineStyleDashDotDot划线后跟两个点
wdLineStyleDashDotStroked划线后跟粗点
表格边框线宽度的WdlineWidth常量的取值情况:
常量值说明
wdlineWidth025pt0.25磅
wdlineWidth050pt0.5磅
wdlineWidth075pt0.75磅
wdlineWidth100pt1磅,默认值
wdlineWidth150pt1.5磅
其他磅值类似,同学们自己改下数字就可以了,要学会举一反三
二.使用VBA处理图片和图形对象
实例1:
将所有图片的宽度统一设置为7厘米
代码:
Sub将所有图片的宽度统一设置为7厘米()
DimInShpAsInlineShape
ForEachInShpInActiveDocument.InlineShapes
WithInShp
If.Type=wdInlineShapePictureThen
.LockAspectRatio=msoTrue
.Width=CentimetersToPoints(7)
EndIf
EndWith
NextInShp
SetInShp=Nothing
EndSub
代码解析:
声明一个InlineShape类型的对象变量InShp,使用该变量遍历文档中的所有嵌入型的对象,通过InlineShape对象的Type属性判断InShp变量当前引用的对象是否是图片,如果是则锁定图片的宽高比,然后将图片宽度设置成7厘米。
实例2:
快速为所有图片添加边框
代码:
Sub快速为所有图片添加边框()
DimInShpAsInlineShape
ForEachInShpInActiveDocument.InlineShapes
WithInShp
If.Type=wdInlineShapePictureThen
.Borders.Enable=True
EndIf
EndWith
NextInShp
SetInShp=Nothing
EndSub
代码解析:
使用InShp变量在文档中遍历图片的方法与上面讲的类似,将InlineShape对象的Borders属性设置为True表示为图片应用默认边框。
实例3:
下面的代码将文档中的所有图形填充色设置为红色
代码:
Sub快速为所有形状设置填充色()
DimshpAsShape
ForEachshpInActiveDocument.Shapes
Withshp
If.Type=msoAutoShapeThen
.Fill.ForeColor=vbRed
EndIf
EndWith
Nextshp
Setshp=Nothing
EndSub
代码解析:
声明一个Shape类型的变量shp,使用该变量遍历当前文档中的每一个浮动型对象,然后使用Shape对象的Type属性判断shp变量当前引用的对象是否是自选图形,如果是则将该图形的前景设置为红色。
实例4:
快速改变所有文本框中的字体颜色
统一将文本框的文字颜色设置为蓝色
代码:
Sub快速改变所有文本框中的字体颜色()
DimshpAsShape
ForEachshpInActiveDocument.Shapes
Ifshp.Type=msoTextBoxThen
shp.TextFrame.TextRange.Font.ColorIndex=wdBlue
EndIf
Nextshp
Setshp=Nothing
EndSub
代码解析:
声明一个Shape类型的变量shp,使用该变量遍历当前文档中的每一个浮动型对象,然后使用Shape对象的Type属性判断shp变量当前引用的对象是否是文本框,如果是则该文本框的文字颜色设置为蓝色。
(wdBlue中的Blue同学可以更改成需要的颜色)
实例5:
批量删除文档中的所有图片
代码:
Sub批量删除文档中的所有图片()
DimInShpAsInlineShape
ForEachInShpInActiveDocument.InlineShapes
IfInShp.Type=wdInlineShapePictureThen
InShp.Delete
EndIf
NextInShp
SetInShp=Nothing
EndSub
实例6:
批量删除文档中的所有自选图形
代码:
Sub批量删除文档中的所有自选图形()
DimshpAsShape
ForEachshpInActiveDocument.Shapes
Ifshp.Type=msoAutoShapeThen
shp.Delete
EndIf
Nextshp
Setshp=Nothing
EndSub
实例7:
批量删除文档中的所有文本框
代码:
Sub批量删除文档中的所有文本框()
DimshpAsShape
ForEachshpInActiveDocument.Shapes
Ifshp.Type=msoTextBoxThen
shp.Delete
EndIf
Nextshp
Setshp=Nothing
EndSub
三.使用VBA处理文本
实例1:
快速将指定内容提取到新文档中
下面的代码将当前文档中包含“word”一词中的所有句子提取到一个新文档中。
代码:
Sub快速将指定内容提取到新文档中()
DimsFindTextAsString
WithSelection
.HomeKeywdStory
With.Find
.ClearFormatting
.Text="Word"
.MatchCase=True
.Forward=True
Do
.Execute
If.Found=FalseThenExitDo
.Parent.Expand(wdSentence)
sFindText=sFindText&Selection.Text&vbCrLf
.Parent.CollapsewdCollapseEnd
Loop
EndWith
EndWith
Documents.Add
Selection.Text=sFindText
EndSub代码解析:
先使用Selection的HomeKey方法将插入点移至文档开头,然后设置查找条件,查找Word一词严格要求匹配大小写,接着使用DoLoop循环按照设置好的条件反复查找指定的内容,使用Find对象的Found属性判断是否找到匹配项,如果未找到则退出DoLoop循环,如果找到匹配项会自动选中该内容,然后将选区拓展到该词所在的句子,同时将每次找到并拓展后的内容存入sFindText变量中,然后将选区折叠到结尾处,继续进行查找,最后新建一个文档,将所有找到的内容输入到新文档中。
更灵活的做法是运行程序后显示一个对话框,允许用户输入要提取的内容,然后根据输入的内容提取相应范围中的内容,而不是将要提取的内容输入到代码中,从而形成缺少灵活性的硬编码,下面是修改后的代码,使用VBA的InputBox函数所创建的对话框接受用户输入的内容,然后检测输入的内容是否为空或者直接单击对话框中的取消按钮,如果是则退出程序,否则在文档中查找输入的内容,找到匹配项则进行提取。
代码:
Sub快速将指定内容提取到新文档中2()
DimsFindTextAsString,sAnsAsString
sAns=InputBox("请输入要提取的关键字","自动提取内容")
IfsAns=""ThenExitSub
WithSelection
.HomeKeywdStory
With.Find
.ClearFormatting
.Text=sAns
.MatchCase=True
.Forward=True
Do
.Execute
If.Found=FalseThenExitDo
.Parent.Expand(wdSentence)
sFindText=sFindText&Selection.Text&vbCrLf
.Parent.CollapsewdCollapseEnd
Loop
EndWith
EndWith
Documents.Add
Selection.Text=sFindText
EndSub
实例2:
批量设置不连续文本的格式
下面的代码将当前文档第一段中的第一段中的1、3、5、7、9这几个序列的文字字体设置为红色并加粗显示
代码:
Sub批量设置不连续文本的格式()
DimavWordAsVariant,iAsInteger
avWord=Array(1,3,5,7,9)
Fori=LBound(avWord)ToUBound(avWord)
WithActiveDocument
With.Paragraphs
(1).Range.Words(avWord(i)).Font
.ColorIndex=wdRed
.Bold=True
EndWith
EndWith
Nexti
EndSub
实例3:
批量设置不连续段落的格式
下面的代码会将文档中的第1、3、6段的大纲级别设置成1级。
代码:
Sub批量设置不连续段落的格式()
DimavParaAsVariant,iAsInteger
avPara=Array(1,3,6)
Fori=LBound(avPara)ToUBound(avPara)
WithActiveDocument
.Paragraphs(avPara(i)).Range.ParagraphFormat.OutlineLevel=wdOutlineLevel1
EndWith
Nexti
EndSub
实例4:
快速删除文档中的所有空行
代码:
Sub快速删除文档中的所有空行()
DimparaAsParagraph
Application.ScreenUpdating=False
ForEachparaInActiveDocument.Paragraphs
IfLen(para.Range)=1Then
para.Range.Delete
EndIf
Nextpara
Application.ScreenUpdating=True
EndSub
代码解析:
空行其实就是只包含一个段落标记的空白段落,因此可以通过判断一个段落的长度来确定是否是一个空白段落,如果段落长度为1,则说明该段落只要一个段落标记,通过使用一个Paragraph类型的对象变量,遍历文档中的每一个段落并判断段落的长度是否为1,如果是则说明该段落只包含一个段落标记,将其删除即可。