利用vba排版1Word格式文档下载.docx

利用vba排版1Word格式文档下载.docx

《利用vba排版1Word格式文档下载.docx》由会员分享，可在线阅读，更多相关《利用vba排版1Word格式文档下载.docx（14页珍藏版）》请在冰豆网上搜索。

快速改变所有文本框中的字体颜色12

批量删除文档中的所有图片12

批量删除文档中的所有自选图形12

批量删除文档中的所有文本框13

三．使用VBA处理文本13

快速将指定内容提取到新文档中13

批量设置不连续文本的格式15

批量设置不连续段落的格式15

快速删除文档中的所有空行16

一.使用VBA处理表格

将每个表格在文档中的以页面为基准居中对齐

代码：

Sub将每个表格在文档中以页面为基准居中对齐（）

DimtblAsTable

ForEachtblInActiveDocument.Tables

tbl.Rows.Alignment=wdAlignRowCenter

Nexttbl

Settbl=Nothing

EndSub

代码解析：

Table对象的Rows代表表格中的所有行。

Rows集合的Aligment属性用于设置整个表格在页面中的对齐方式：

wdAlignRowCenter居中（wdAlignRowLeft左对齐默认值，wdAlignRowRight右对齐）

将每个表格中的所有文本在单元格中自动居中对齐

Sub将每个表格中的所有文本在单元格中自动居中对齐（）

tbl.Range.ParagraphFormat.Alignment=wdAlignParagraphCenter

Table对象的Range属性返回一个Range对象，代表一个表格在文档中的范围，使用Range对象的ParagphForment属性返回一个ParagraphFormat对象，用于设置表格内容的段落格式，ParagraphFormat对象的Aligement属性用于设置段落的对齐方式。

删除文档中的所有表格

Sub删除文档中的所有表格（）

tbl.Delete

删除文档中的所有表格包含的空行

Sub删除文档中的所有表格包含的空行（）

DimiRowAsInteger

ForiRow=tbl.Rows.CountTo1Step-1

IfLen（tbl.Rows（iRow）.Range.Text）=（tbl.Columns.Count+1）*2Then

tbl.Rows（iRow）.Delete

EndIf

NextiRow

表格中的一个空白单元格的长度为2=1个段落标记+1个表格边框线，每行最后一个单元格右侧，也就是位于表格外侧还有一个段落标记，该段落标记的长度也为2，因此，需要检测每行的总长度是否等于（表格列数+1）X2如果是则说明该行为空行，否则不是空行，Len（tbl.Rows（iRow）.Range.Text）语句表示表格某行包含文本的总长度

在表格第一列的每个单元格中插入指定的图片

自动插入6张照片第一个表格中的第一列的每个单元格中，6张图片和表格所属的文档位于同一个文件夹中。

Sub在表格第一列的每个单元格中插入指定的图片（）

DimiAsInteger

DimvPicAsVariant

DimsFullNameAsString

OnErrorResumeNext

Settbl=ActiveDocument.Tables

（1）

IfErr.Number<

>

0Then

MsgBox"

请先创建一个不少于6行的表格"

ExitSub

vPic=Array（"

辣椒"

"

胡萝卜"

西红柿"

柚子"

草莓"

猕猴桃"

）

Fori=LBound（vPic）ToUBound（vPic）

sFullName=tbl.Parent.Path&

"

\"

&

vPic（i）&

.jpg"

tbl.Columns

（1）.Cells（i+1）.Range.InlineShapes.AddPicturesFullName

Nexti

自动将文档中的每个表格上方的标题汇总到新文档中

如果文档中的每个表格上面的一行都包含一个标题，下面的代码将与每个表格相关的标题提取到一个新文档中

Sub自动将文档中的每个表格上方的标题汇总到新文档中（）

DimrngAsRange

DimsTitleAsString

Setrng=ActiveDocument.Range（tbl.Range.Start-1,tbl.Range.Start-1）

rng.Expand（wdParagraph）

sTitle=sTitle&

rng.Text

Documents.Add

Selection.Text=sTitle

Setrng=Nothing

代码中声明了三个变量，tbl变量常用于遍历文档中的每一个表格，rng变量用于指定表格上方的标题范围，sTitle变量用于保存所有表格的标题，使用tbl变量遍历当前文档的每一个表格，在遍历每个单元格时，定义rng变量的范围为表格上方的段落的结尾位置，tbl.Range返回整个表格在文档中的范围，tbl.Range.Start返回表格的起始位置，将该值减1得到上一个段落结尾的位置，使用Range对象的Expand方法将rng变量中定义范围拓展到整个段落，然后将rng变量所表示的范围中的内容赋值给sTitle变量，在文档的每个表格中重复以上操作，最后将Stitle变量中保存的所有表格的标题写入新建的文档中。

下面的代码一次性删除文档中所有表格的内外边框线和底纹效果

Sub删除打开的所有文档中所有表格的内外边框线和底纹效果（）

DimdocAsDocument

ForEachdocInDocuments

ForEachtblIndoc.Tables

tbl.Borders.OutsideLineStyle=wdLineStyleNone

tbl.Borders.InsideLineStyle=wdLineStyleNone

tbl.Rows

（1）.Shading.BackgroundPatternColor=wdColorAutomatic

Nextdoc

Setdoc=Nothing

统一设置所有表格标题行的底纹颜色

下面的代码自动将当前文档中的所有表格的标题行设置灰色底纹

Sub统一设置所有表格标题行的底纹颜色（）

tbl.Rows

（1）.Shading.BackgroundPatternColor=wdColorGray15

Table对象的Ros属性代表表格中的所有行，使用Rows

（1）引用表格的第一行同时返回一个Row对象，然后使用Row对象的Shading属性设置表格的底纹效果。

本例中的wdColorGray15表示12%灰度，更多颜色：

常量值说明

wdColorAutomatic自动配色，默认值。

一般取决于文档的主题颜色

wdColorGray055%灰色底纹

wdColorGray1010%灰色底纹

wdColorGray12512.5%灰色底纹

wdColorGray37537.5%灰色底纹（其他量值改下数据就可以）

wdColorBlue蓝色

wdColorBlack黑色

wdColorBrown褐色

wdColorRed红色

wdColorGreen绿色

wdColorYellow黄色

wdColorViolet紫色（其他颜色一样设置，查下颜色的英语就可以）

统一设置所有表格的边框线样式

下面代码将当前表格的外边框线设置为1.5磅宽的单线，将内边框线设置为1磅的点划线

Sub统一设置所有表格的边框线样式（）

Withtbl.Borders

.OutsideLineStyle=wdLineStyleSingle

.OutsideLineWidth=wdLineWidth150pt

.InsideLineStyle=wdLineStyleDashDot

.InsideLineWidth=wdLineWidth100pt

EndWith

设置表格边框线线型需要使用WdlineStyle常量，该常量的取值情况：

wdLineStyleNone无边框

wdLineStyleSingle单实线

wdLineStyleDouble双实线

wdLineStyleTriple三条细实线

wdLineStylesingleWavy波浪型单实线

wdLineStyleDot点

wdLineStyleDashDot划线后跟单个点

wdLineStyleDashDotDot划线后跟两个点

wdLineStyleDashDotStroked划线后跟粗点

表格边框线宽度的WdlineWidth常量的取值情况：

常量值说明

wdlineWidth025pt0.25磅

wdlineWidth050pt0.5磅

wdlineWidth075pt0.75磅

wdlineWidth100pt1磅，默认值

wdlineWidth150pt1.5磅

其他磅值类似，同学们自己改下数字就可以了，要学会举一反三

二.使用VBA处理图片和图形对象

将所有图片的宽度统一设置为7厘米

Sub将所有图片的宽度统一设置为7厘米（）

DimInShpAsInlineShape

ForEachInShpInActiveDocument.InlineShapes

WithInShp

If.Type=wdInlineShapePictureThen

.LockAspectRatio=msoTrue

.Width=CentimetersToPoints（7）

NextInShp

SetInShp=Nothing

声明一个InlineShape类型的对象变量InShp，使用该变量遍历文档中的所有嵌入型的对象，通过InlineShape对象的Type属性判断InShp变量当前引用的对象是否是图片，如果是则锁定图片的宽高比，然后将图片宽度设置成7厘米。

快速为所有图片添加边框

Sub快速为所有图片添加边框（）

.Borders.Enable=True

使用InShp变量在文档中遍历图片的方法与上面讲的类似，将InlineShape对象的Borders属性设置为True表示为图片应用默认边框。

下面的代码将文档中的所有图形填充色设置为红色

Sub快速为所有形状设置填充色（）

DimshpAsShape

ForEachshpInActiveDocument.Shapes

Withshp

If.Type=msoAutoShapeThen

.Fill.ForeColor=vbRed

Nextshp

Setshp=Nothing

声明一个Shape类型的变量shp,使用该变量遍历当前文档中的每一个浮动型对象，然后使用Shape对象的Type属性判断shp变量当前引用的对象是否是自选图形，如果是则将该图形的前景设置为红色。

快速改变所有文本框中的字体颜色

统一将文本框的文字颜色设置为蓝色

Sub快速改变所有文本框中的字体颜色（）

Ifshp.Type=msoTextBoxThen

shp.TextFrame.TextRange.Font.ColorIndex=wdBlue

代码解析:

声明一个Shape类型的变量shp，使用该变量遍历当前文档中的每一个浮动型对象，然后使用Shape对象的Type属性判断shp变量当前引用的对象是否是文本框，如果是则该文本框的文字颜色设置为蓝色。

（wdBlue中的Blue同学可以更改成需要的颜色）

批量删除文档中的所有图片

Sub批量删除文档中的所有图片（）

IfInShp.Type=wdInlineShapePictureThen

InShp.Delete

批量删除文档中的所有自选图形

Sub批量删除文档中的所有自选图形（）

Ifshp.Type=msoAutoShapeThen

shp.Delete

批量删除文档中的所有文本框

Sub批量删除文档中的所有文本框（）

三．使用VBA处理文本

快速将指定内容提取到新文档中

下面的代码将当前文档中包含“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

Selection.Text=sFindText

EndSub代码解析：

先使用Selection的HomeKey方法将插入点移至文档开头，然后设置查找条件，查找Word一词严格要求匹配大小写，接着使用DoLoop循环按照设置好的条件反复查找指定的内容，使用Find对象的Found属性判断是否找到匹配项，如果未找到则退出DoLoop循环，如果找到匹配项会自动选中该内容，然后将选区拓展到该词所在的句子，同时将每次找到并拓展后的内容存入sFindText变量中，然后将选区折叠到结尾处，继续进行查找，最后新建一个文档，将所有找到的内容输入到新文档中。

更灵活的做法是运行程序后显示一个对话框，允许用户输入要提取的内容，然后根据输入的内容提取相应范围中的内容，而不是将要提取的内容输入到代码中，从而形成缺少灵活性的硬编码，下面是修改后的代码，使用VBA的InputBox函数所创建的对话框接受用户输入的内容，然后检测输入的内容是否为空或者直接单击对话框中的取消按钮，如果是则退出程序，否则在文档中查找输入的内容，找到匹配项则进行提取。

Sub快速将指定内容提取到新文档中2（）

DimsFindTextAsString,sAnsAsString

sAns=InputBox（"

请输入要提取的关键字"

自动提取内容"

IfsAns="

"

ThenExitSub

.Text=sAns

批量设置不连续文本的格式

下面的代码将当前文档第一段中的第一段中的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

批量设置不连续段落的格式

下面的代码会将文档中的第1、3、6段的大纲级别设置成1级。

Sub批量设置不连续段落的格式（）

DimavParaAsVariant,iAsInteger

avPara=Array（1,3,6）

Fori=LBound（avPara）ToUBound（avPara）

.Paragraphs（avPara（i））.Range.ParagraphFormat.OutlineLevel=wdOutlineLevel1

快速删除文档中的所有空行

代码:

Sub快速删除文档中的所有空行（）

DimparaAsParagraph

Application.ScreenUpdating=False

ForEachparaInActiveDocument.Paragraphs

IfLen（para.Range）=1Then

para.Range.Delete

Nextpara

Application.ScreenUpdating=True

空行其实就是只包含一个段落标记的空白段落，因此可以通过判断一个段落的长度来确定是否是一个空白段落，如果段落长度为1，则说明该段落只要一个段落标记，通过使用一个Paragraph类型的对象变量，遍历文档中的每一个段落并判断段落的长度是否为1，如果是则说明该段落只包含一个段落标记，将其删除即可。