循环在WORD+VBA中的应用Word版

循环在WORD VBA中的应用

[001]在活动文档的开头插入一张 4 列 3 行的表格。For Each...Next 结构用于循环遍历表格中的每个单元格。在 For Each...Next 结构中，InsertAfter 方法用于将文字添至表格单元格（单元格 1、单元格 2、以此类推）。

Sub CreateNewTable()

Dim docActive As Document

Dim tblNew As Table

Dim celTable As Cell

Dim intCount As Integer

Set docActive = ActiveDocument

Set tblNew = docActive.Tables.Add( _

Range:=docActive.Range(Start:=0, End:=0), NumRows:=3, _

NumColumns:=4)

intCount = 1

For Each celTable In tblNew.Range.Cells

celTable.Range.InsertAfter "Cell " & intCount

intCount = intCount + 1

Next celTable

tblNew.AutoFormat Format:=wdTableFormatColorful2, _

ApplyBorders:=True, ApplyFont:=True, ApplyColor:=True

End Sub

[002]在活动文档中第一张表格的第一个单元格中插入文字。Cell 方法返回单独的 Cell 对象。Range 属性返回一个 Range 对象。Delete 方法用于删除现有的文字，而 InsertAfter 方法用于插入文字“Cell 1,1”。

Sub InsertTextInCell()

If ActiveDocument.Tables.Count >= 1 Then

With ActiveDocument.Tables(1).Cell(Row:=1, Column:=1).Range

.Delete

.InsertAfter Text:="Cell 1,1"

End With

End If

End Sub

[003]返回并显示文档中第一张表格的第一行中每个单元格的内容。

Sub ReturnTableText()

Dim tblOne As Table

Dim celTable As Cell

Dim rngTable As Range

Set tblOne = ActiveDocument.Tables(1)

For Each celTable In tblOne.Rows(1).Cells

Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, _

End:=celTable.Range.End - 1)

MsgBox rngTable.Text

Next celTable

End Sub

Sub ReturnCellText()

Dim tblOne As Table

Dim celTable As Cell

Dim rngTable As Range

Set tblOne = ActiveDocument.Tables(1)

For Each celTable In tblOne.Rows(1).Cells

Set rngTable = celTable.Range

rngTable.MoveEnd Unit:=wdCharacter, Count:=-1

MsgBox rngTable.Text

Next celTable

End Sub

[004]在活动文档的开头插入用制表符分隔的文本，然后将这些文本转换为表格。

Sub ConvertExistingText()

With Documents.Add.Content

.InsertBefore "one" & vbTab & "two" & vbTab & "three" & vbCr

.ConvertToTable Separator:=Chr(9), NumRows:=1, NumColumns:=3

End With

End Sub

[005]定义一个数组，该数组的元素个数等于文档中第一张表格（假定为 Option Base 1）中的单元格数。For Each...Next 结构用于返回每个表格单元格的内容，并将文字指定给相应的数组元素。

Sub ReturnCellContentsToArray()

Dim intCells As Integer

Dim celTable As Cell

Dim strCells() As String

Dim intCount As Integer

Dim rngText As Range

If ActiveDocument.Tables.Count >= 1 Then

With ActiveDocument.Tables(1).Range

intCells = .Cells.Count

ReDim strCells(intCells)

intCount = 1

For Each celTable In .Cells

Set rngText = celTable.Range

rngText.MoveEnd Unit:=wdCharacter, Count:=-1 strCells(intCount) = rngText

intCount = intCount + 1

Next celTable

End With

End If

End Sub

[006]将当前文档中的表格复制到新文档中。

Sub CopyTablesToNewDoc()

Dim docOld As Document

Dim rngDoc As Range

Dim tblDoc As Table

If ActiveDocument.Tables.Count >= 1 Then

Set docOld = ActiveDocument

Set rngDoc = Documents.Add.Range(Start:=0, End:=0) For Each tblDoc In docOld.Tables

tblDoc.Range.Copy

With rngDoc

.Paste

.Collapse Direction:=wdCollapseEnd

.InsertParagraphAfter

.Collapse Direction:=wdCollapseEnd

End With

Next

End If

End Sub

[007]显示 Documents 集合中每个文档的名称。

Sub LoopThroughOpenDocuments()

Dim docOpen As Document

For Each docOpen In Documents

MsgBox https://www.wendangku.net/doc/e211996823.html,

Next docOpen

End Sub

[008]使用数组存储活动文档中包含的所有书签的名称。

Sub LoopThroughBookmarks()

Dim bkMark As Bookmark

Dim strMarks() As String

Dim intCount As Integer

If ActiveDocument.Bookmarks.Count > 0 Then

ReDim strMarks(ActiveDocument.Bookmarks.Count - 1)

intCount = 0

For Each bkMark In ActiveDocument.Bookmarks

strMarks(intCount) = https://www.wendangku.net/doc/e211996823.html,

intCount = intCount + 1

Next bkMark

End If

End Sub

[009]更新活动文档中的 DATE 域。

Sub UpdateDateFields()

Dim fldDate As Field

For Each fldDate In ActiveDocument.Fields

If InStr(1, fldDate.Code, "Date", 1) Then fldDate.Update

Next fldDate

End Sub

[010]如果名为“Filename”的词条是 AutoTextEntries 集合中的一部分，则以下示例显示一条消息。

Sub FindAutoTextEntry()

Dim atxtEntry As AutoTextEntry

For Each atxtEntry In ActiveDocument.AttachedTemplate.AutoTextEntries

If https://www.wendangku.net/doc/e211996823.html, = "Filename" Then _

MsgBox "The Filename AutoText entry exists."

Next atxtEntry

End Sub

[011]在第一个表格中添加一行，然后将文本 Cell 插入该行。

Sub CountCells()

Dim tblNew As Table

Dim rowNew As Row

Dim celTable As Cell

Dim intCount As Integer

intCount = 1

Set tblNew = ActiveDocument.Tables(1)

Set rowNew = tblNew.Rows.Add(BeforeRow:=tblNew.Rows(1))

For Each celTable In rowNew.Cells

celTable.Range.InsertAfter Text:="Cell " & intCount

intCount = intCount + 1

Next celTable

End Sub

[012]向新文档中添加一个 3 行 5 列的表格，然后在表格的每个单元格中插入数据。

Sub NewTable()

Dim docNew As Document

Dim tblNew As Table

Dim intX As Integer

Dim intY As Integer

Set docNew = Documents.Add

Set tblNew = docNew.Tables.Add(Selection.Range, 3, 5)

With tblNew

For intX = 1 To 3

For intY = 1 To 5

.Cell(intX, intY).Range.InsertAfter "Cell: R" & intX & ", C" & intY Next intY

Next intX

.Columns.AutoFit

End With

End Sub

[013]将 Blue 变量的值设为 6，如果该变量不存在，本示例将该变量添加至文档，并将值设为 6。

For Each aVar In ActiveDocument.Variables

If https://www.wendangku.net/doc/e211996823.html, = "Blue" Then num = aVar.Index

Next aVar

If num = 0 Then

ActiveDocument.Variables.Add Name:="Blue", Value:=6

Else

ActiveDocument.Variables(num).Value = 6

End If

[014]在文档关闭以前提示用户保存文档。

Sub PromptToSaveAndClose()

Dim doc As Document

For Each doc In Documents

doc.Close SaveChanges:=wdPromptToSaveChanges

Next

End Sub

[015]若要确定文档是否处于打开状态，可使用 For Each...Next 语句列举 Documents 集合中的元素。如果文档 Sample.doc 是打开的，则下列示例激活该文档，如果没有打开文档，则将该文档打开。

Sub ActivateOrOpenDocument()

Dim doc As Document

Dim docFound As Boolean

For Each doc In Documents

If InStr(1, https://www.wendangku.net/doc/e211996823.html,, "sample.doc", 1) Then

doc.Activate

docFound = True

Exit For

Else

docFound = False

End If

Next doc

If docFound = False Then Documents.Open FileName:="Sample.doc"

End Sub

[016]第三个多级符号列表模板创建另一种编号样式。

Set myTemp = ListGalleries(wdOutlineNumberGallery).ListTemplates(3)

For i = 1 to 9

If i Mod 2 = 0 Then

myTemp.ListLevels(i).NumberStyle = _

wdListNumberStyleUppercaseRoman

Else

myTemp.ListLevels(i).NumberStyle = _

wdListNumberStyleLowercaseRoman

End If

Next i

[017]将活动文档中每个多级符号列表的编号样式更改为大写字母。

For Each lt In ActiveDocument.ListTemplates

For Each ll In lt.listlevels

ll.NumberStyle = wdListNumberStyleUppercaseLetter

Next ll

Next lt

[018]将活动文档页脚中的页码格式设置为小写罗马数字。

For Each sec In ActiveDocument.Sections

sec.Footers(wdHeaderFooterPrimary).PageNumbers _

.NumberStyle = wdPageNumberStyleLowercaseRoman

Next sec

[019]显示活动文档各列表的项数。

For Each li In ActiveDocument.Lists

MsgBox li.CountNumberedItems

Next li

[020]显示活动文档中每个段落的样式。

For Each para in ActiveDocument.Paragraphs

MsgBox para.Style

Next para

[021]交替设置活动文档中的所有段落为“标题 3”和“正文”样式。

For i = 1 To ActiveDocument.Paragraphs.Count

If i Mod 2 = 0 Then

ActiveDocument.Paragraphs(i).Style = wdStyleNormal

Else: ActiveDocument.Paragraphs(i).Style = wdStyleHeading3

End If

Next i

[022]显示所选内容中每个字符的样式。Characters 集合的每个元素都是一个 Range 对象。

For each c in Selection.Characters

MsgBox c.Style

Next c

[023]将从 Normal 模板中删除名为“Custom 1”的工具栏。

Dim cbLoop As CommandBar

For Each cbLoop In CommandBars

If https://www.wendangku.net/doc/e211996823.html, = "Custom 1" Then

https://www.wendangku.net/doc/e211996823.html,anizerDelete Source:=https://www.wendangku.net/doc/e211996823.html,, _

Name:="Custom 1", _

Object:=wdOrganizerObjectCommandBars

End If

Next cbLoop

[024]提示用户删除活动文档的相关模板中的每一个“自动图文集”词条。如果用户单击“确定”按钮，则将删除“自动图文集”词条。

Dim atEntry As AutoTextEntry

Dim intResponse As Integer

For Each atEntry In _

ActiveDocument.AttachedTemplate.AutoTextEntries

intResponse = _

MsgBox("Do you want to delete the " & https://www.wendangku.net/doc/e211996823.html, _

& " AutoText entry?", vbYesNoCancel)

If intResponse = vbYes Then

With ActiveDocument.AttachedTemplate

https://www.wendangku.net/doc/e211996823.html,anizerDelete _

Source:= .Path & "\" & .Name, _

Name:=https://www.wendangku.net/doc/e211996823.html,, _

Object:=wdOrganizerObjectAutoText

End With

ElseIf intResponse = vbCancel Then

Exit For

End If

Next atEntry

[025]显示 Word 启动时自动加载的每一加载项的名称。

Dim addinLoop as AddIn

Dim blnFound as Boolean

blnFound = False

For Each addinLoop In AddIns

With addinLoop

If .Autoload = True Then

MsgBox .Name

blnFound = True

End If

End With

Next addinLoop

If blnFound <> True Then _

MsgBox "No add-ins were loaded automatically."

[026]判断名为“Gallery.dot”的加载项是否自动加载。

Dim addinLoop as AddIn

For Each addinLoop In AddIns

If InStr(LCase$(https://www.wendangku.net/doc/e211996823.html,), "gallery.dot") > 0 Then

If addinLoop.Autoload = True Then Msgbox "Autoload"

End If

Next addinLoop

[027]为所选内容的第一节的每个页面添加由黑点构成的边框。

Dim borderLoop As Border

For Each borderLoop In Selection.Sections(1).Borders

With borderLoop

.ArtStyle = wdArtBasicBlackDots

.ArtWidth = 6

End With

Next borderLoop

[028]为活动文档中的第一节的每个页面添加由特定图片所构成的边框。

Dim borderLoop As Border

With ActiveDocument.Sections(1)

.Borders.AlwaysInFront = True

For Each borderLoop In .Borders

With borderLoop

.ArtStyle = wdArtPeople

.ArtWidth = 15

End With

Next borderLoop

End With

[029]如果未将 Word 设置为自动更新链接，则更新活动文档中所有以 OLE 对象形式链接的图形。

Dim shapeLoop as Shape

For Each shapeLoop In ActiveDocument.Shapes

With shapeLoop

If .Type = msoLinkedOLEObject Then

If .LinkFormat.AutoUpdate = False Then

.LinkFormat.Update

End If

End If

End With

Next s

[030]更新活动文档中未被自动更新的域。

Dim fieldLoop as Field

For Each fieldLoop In ActiveDocument.Fields

If fieldLoop.LinkFormat.AutoUpdate = False Then _

fieldLoop.LinkFormat.Update

Next fieldLoop

[031]在活动文档中的所有居中段落底部应用下边框。

For Each para In ActiveDocument.Paragraphs

If para.Alignment = wdAlignParagraphCenter Then

para.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle

para.Borders(wdBorderBottom).LineWidth = wdLineWidth300pt

End If

Next para

[032]为当前节中的所有页面添加边框。

For Each aBorder In Selection.Sections(1).Borders

aBorder.ArtStyle = wdArtBasicBlackDots

aBorder.ArtWidth = 6

Next aBorder

[033]检查活动文档中的所有样式，如果检查到一个非内置样式，则显示该样式的名称。

Dim styleLoop As Style

For Each styleLoop in ActiveDocument.Styles

If styleLoop.BuiltIn = False Then

Msgbox https://www.wendangku.net/doc/e211996823.html,Local

End If

Next styleLoop

[034]检查应用程序中创建的所有题注标签，如果检查到一个非内置的题注标签，则显示该标签的名称。

Dim clLoop As CaptionLabel

For Each clLoop in CaptionLabels

If clLoop.BuiltIn = False Then

Msgbox https://www.wendangku.net/doc/e211996823.html,

End If

Next clLoop

[035]在父节点中添加子节点，并在父节点中显示文本以代表创建的子节点数目。

Sub CountChildNodes()

Dim shpDiagram As Shape

Dim dgnNode As DiagramNode

Dim shpText As Shape

Dim intCount As Integer

'Add radial diagram to the current document

Set shpDiagram = ThisDocument.Shapes.AddDiagram _

(Type:=msoDiagramRadial, Left:=10, _

Top:=15, Width:=400, Height:=475)

'Add first node to the diagram

Set dgnNode = shpDiagram.DiagramNode.Children.AddNode

'Add three child nodes

For intCount = 1 To 3

dgnNode.Children.AddNode

Next intCount

'Add a text box for each node in the diagram

For intCount = 1 To 4

Set shpText = shpDiagram.DiagramNode.Children(1).TextShape

shpText.TextFrame.TextRange.Text = Str(intCount)

Next intCount

End Sub

[036]将与活动文档相关的模板中的所有“自动图文集”词条复制到 Normal 模板中。

Dim atEntry As AutoTextEntry

For Each atEntry In _

ActiveDocument.AttachedTemplate.AutoTextEntries

https://www.wendangku.net/doc/e211996823.html,anizerCopy _

Source:=ActiveDocument.AttachedTemplate.FullName, _

Destination:=NormalTemplate.FullName, Name:=https://www.wendangku.net/doc/e211996823.html,, _

Object:=wdOrganizerObjectAutoText

Next atEntry

[037]如果活动文档中含有名为“SubText”的样式，本示例将该样式复制到

C:\Templates\Template1.dot 中。

Dim styleLoop As Style

For Each styleLoop In ActiveDocument.Styles

If styleLoop = "SubText" Then

https://www.wendangku.net/doc/e211996823.html,anizerCopy Source:=https://www.wendangku.net/doc/e211996823.html,, _

Destination:="C:\Templates\Template1.dot", _

Name:="SubText", _

Object:=wdOrganizerObjectStyles

End If

Next styleLoop

[038]显示各打开文档的名称。

For Each aDoc In Documents

aName = aName & https://www.wendangku.net/doc/e211996823.html, & vbCr

Next aDoc

MsgBox aName

[039]查看 Documents 集合以判定名为“Report.doc”的文档是否已打开。如果该文档包含在 Documents 集合中，则激活该文档；否则，打开该文档。

For Each doc In Documents

If https://www.wendangku.net/doc/e211996823.html, = "Report.doc" Then found = True

Next doc

If found <> True Then

Documents.Open FileName:="C:\Documents\Report.doc"

Else

Documents("Report.doc").Activate

End If

[040]如果 FirstLetterExceptions 集合包含缩写“addr.”，则下列示例将其从中删除。

For Each aExcept In AutoCorrect.FirstLetterExceptions

If https://www.wendangku.net/doc/e211996823.html, = "addr." Then aExcept.Delete

Next aExcept

[041]创建一篇新文档，然后插入所有的自动更正的首字母例外项。

Documents.Add

For Each aExcept In AutoCorrect.FirstLetterExceptions

With Selection

.InsertAfter https://www.wendangku.net/doc/e211996823.html,

.InsertParagraphAfter

.Collapse Direction:=wdCollapseEnd

End With

Next aExcept

[042]显示与 Windows 集合的第一个窗口相关的窗格中所有的非打印字符。

For Each myPane In Windows(1).Panes

myPane.View.ShowAll = True

Next myPane