循环在WORD VBA中的应用

1、循环在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 = docAc

2、tive.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, _ ApplyBo

3、rders:=True, ApplyFont:=True, ApplyColor:=TrueEnd Sub002在活动文档中第一张表格的第一个单元格中插入文字。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).Rang

4、e .Delete .InsertAfter Text:="Cell 1,1" End With End IfEnd Sub003返回并显示文档中第一张表格的第一行中每个单元格的内容。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.Ran

5、ge(Start:=celTable.Range.Start, _ End:=celTable.Range.End - 1) MsgBox rngTable.Text Next celTableEnd SubSub 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 rn

6、gTable.MoveEnd Unit:=wdCharacter, Count:=-1 MsgBox rngTable.Text Next celTableEnd Sub004在活动文档的开头插入用制表符分隔的文本，然后将这些文本转换为表格。Sub ConvertExistingText() With Documents.Add.Content .InsertBefore "one" & vbTab & "two" & vbTab & "three" & vbCr .ConvertToTable

7、 Separator:=Chr(9), NumRows:=1, NumColumns:=3 End WithEnd Sub005定义一个数组，该数组的元素个数等于文档中第一张表格（假定为 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 A

8、s 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

9、 + 1 Next celTable End With End IfEnd Sub006将当前文档中的表格复制到新文档中。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.Ta

10、bles tblDoc.Range.Copy With rngDoc .Paste .Collapse Direction:=wdCollapseEnd .InsertParagraphAfter .Collapse Direction:=wdCollapseEnd End With Next End IfEnd Sub007显示 Documents 集合中每个文档的名称。Sub LoopThroughOpenDocuments() Dim docOpen As Document For Each docOpen In Documents MsgBox docOpen.Name Next do

11、cOpenEnd Sub008使用数组存储活动文档中包含的所有书签的名称。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(i

12、ntCount) = bkMark.Name intCount = intCount + 1 Next bkMark End IfEnd Sub009更新活动文档中的 DATE 域。Sub UpdateDateFields() Dim fldDate As Field For Each fldDate In ActiveDocument.Fields If InStr(1, fldDate.Code, "Date", 1) Then fldDate.Update Next fldDateEnd Sub010如果名为“Filename”的词条是 AutoTextEntries

13、 集合中的一部分，则以下示例显示一条消息。Sub FindAutoTextEntry() Dim atxtEntry As AutoTextEntry For Each atxtEntry In ActiveDocument.AttachedTemplate.AutoTextEntries If atxtEntry.Name = "Filename" Then _ MsgBox "The Filename AutoText entry exists." Next atxtEntryEnd Sub011在第一个表格中添加一行，然后将文本 Cell 插入该行

14、。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 " & in

15、tCount intCount = intCount + 1 Next celTableEnd Sub012向新文档中添加一个 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

16、 For intY = 1 To 5 .Cell(intX, intY).Range.InsertAfter "Cell: R" & intX & ", C" & intY Next intY Next intX .Columns.AutoFit End WithEnd Sub013将 Blue 变量的值设为 6，如果该变量不存在，本示例将该变量添加至文档，并将值设为 6。For Each aVar In ActiveDocument.Variables If aVar.Name = "Blue" Then n

17、um = aVar.IndexNext aVarIf num = 0 Then ActiveDocument.Variables.Add Name:="Blue", Value:=6Else ActiveDocument.Variables(num).Value = 6End If014在文档关闭以前提示用户保存文档。Sub PromptToSaveAndClose() Dim doc As Document For Each doc In Documents doc.Close SaveChanges:=wdPromptToSaveChanges NextEnd Sub0

18、15若要确定文档是否处于打开状态，可使用 For Each.Next 语句列举 Documents 集合中的元素。如果文档 Sample.doc 是打开的，则下列示例激活该文档，如果没有打开文档，则将该文档打开。Sub ActivateOrOpenDocument() Dim doc As Document Dim docFound As Boolean For Each doc In Documents If InStr(1, doc.Name, "sample.doc", 1) Then doc.Activate docFound = True Exit For Els

19、e docFound = False End If Next doc If docFound = False Then Documents.Open FileName:="Sample.doc"End Sub016第三个多级符号列表模板创建另一种编号样式。Set myTemp = ListGalleries(wdOutlineNumberGallery).ListTemplates(3)For i = 1 to 9 If i Mod 2 = 0 Then myTemp.ListLevels(i).NumberStyle = _ wdListNumberStyleUpperc

20、aseRoman Else myTemp.ListLevels(i).NumberStyle = _ wdListNumberStyleLowercaseRoman End IfNext i017将活动文档中每个多级符号列表的编号样式更改为大写字母。For Each lt In ActiveDocument.ListTemplates For Each ll In lt.listlevels ll.NumberStyle = wdListNumberStyleUppercaseLetter Next llNext lt018将活动文档页脚中的页码格式设置为小写罗马数字。For Each sec

21、 In ActiveDocument.Sections sec.Footers(wdHeaderFooterPrimary).PageNumbers _ .NumberStyle = wdPageNumberStyleLowercaseRomanNext sec019显示活动文档各列表的项数。For Each li In ActiveDocument.Lists MsgBox li.CountNumberedItemsNext li020显示活动文档中每个段落的样式。For Each para in ActiveDocument.Paragraphs MsgBox para.StyleNext

22、 para021交替设置活动文档中的所有段落为“标题 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 IfNext i022显示所选内容中每个字符的样式。Characters 集合的每个元素都是一个 Range 对象。For each c in Selection.Ch

23、aracters MsgBox c.StyleNext c023将从 Normal 模板中删除名为“Custom 1”的工具栏。Dim cbLoop As CommandBarFor Each cbLoop In CommandBars If cbLoop.Name = "Custom 1" Then Application.OrganizerDelete Source:=NormalTemplate.Name, _ Name:="Custom 1", _ Object:=wdOrganizerObjectCommandBars End IfNext c

24、bLoop024提示用户删除活动文档的相关模板中的每一个“自动图文集”词条。如果用户单击“确定”按钮，则将删除“自动图文集”词条。Dim atEntry As AutoTextEntryDim intResponse As IntegerFor Each atEntry In _ ActiveDocument.AttachedTemplate.AutoTextEntries intResponse = _ MsgBox("Do you want to delete the " & atEntry.Name _ & " AutoText entry?

25、", vbYesNoCancel) If intResponse = vbYes Then With ActiveDocument.AttachedTemplate Application.OrganizerDelete _ Source:= .Path & "" & .Name, _ Name:=atEntry.Name, _ Object:=wdOrganizerObjectAutoText End With ElseIf intResponse = vbCancel Then Exit For End IfNext atEntry025显示

26、Word 启动时自动加载的每一加载项的名称。Dim addinLoop as AddInDim blnFound as BooleanblnFound = FalseFor Each addinLoop In AddIns With addinLoop If .Autoload = True Then MsgBox .Name blnFound = True End If End WithNext addinLoopIf blnFound <> True Then _ MsgBox "No add-ins were loaded automatically."0

27、26判断名为“Gallery.dot”的加载项是否自动加载。Dim addinLoop as AddInFor Each addinLoop In AddIns If InStr(LCase$(addinLoop.Name), "gallery.dot") > 0 Then If addinLoop.Autoload = True Then Msgbox "Autoload" End IfNext addinLoop027为所选内容的第一节的每个页面添加由黑点构成的边框。Dim borderLoop As BorderFor Each border

28、Loop In Selection.Sections(1).Borders With borderLoop .ArtStyle = wdArtBasicBlackDots .ArtWidth = 6 End WithNext borderLoop028为活动文档中的第一节的每个页面添加由特定图片所构成的边框。Dim borderLoop As BorderWith ActiveDocument.Sections(1) .Borders.AlwaysInFront = True For Each borderLoop In .Borders With borderLoop .ArtStyle =

29、 wdArtPeople .ArtWidth = 15 End With Next borderLoopEnd With029如果未将 Word 设置为自动更新链接，则更新活动文档中所有以 OLE 对象形式链接的图形。Dim shapeLoop as ShapeFor Each shapeLoop In ActiveDocument.Shapes With shapeLoop If .Type = msoLinkedOLEObject Then If .LinkFormat.AutoUpdate = False Then .LinkFormat.Update End If End If End

30、 WithNext s030更新活动文档中未被自动更新的域。Dim fieldLoop as FieldFor Each fieldLoop In ActiveDocument.Fields If fieldLoop.LinkFormat.AutoUpdate = False Then _ fieldLoop.LinkFormat.UpdateNext fieldLoop031在活动文档中的所有居中段落底部应用下边框。For Each para In ActiveDocument.Paragraphs If para.Alignment = wdAlignParagraphCenter The

31、n para.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle para.Borders(wdBorderBottom).LineWidth = wdLineWidth300pt End IfNext para032为当前节中的所有页面添加边框。For Each aBorder In Selection.Sections(1).Borders aBorder.ArtStyle = wdArtBasicBlackDots aBorder.ArtWidth = 6Next aBorder033检查活动文档中的所有样式，如果检查到一个非内置样

32、式，则显示该样式的名称。Dim styleLoop As StyleFor Each styleLoop in ActiveDocument.Styles If styleLoop.BuiltIn = False Then Msgbox styleLoop.NameLocal End IfNext styleLoop034检查应用程序中创建的所有题注标签，如果检查到一个非内置的题注标签，则显示该标签的名称。Dim clLoop As CaptionLabelFor Each clLoop in CaptionLabels If clLoop.BuiltIn = False Then Msgbo

33、x clLoop.Name End IfNext clLoop035在父节点中添加子节点，并在父节点中显示文本以代表创建的子节点数目。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:=msoDiagram

34、Radial, 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

35、4 Set shpText = shpDiagram.DiagramNode.Children(1).TextShape shpText.TextFrame.TextRange.Text = Str(intCount) Next intCountEnd Sub036将与活动文档相关的模板中的所有“自动图文集”词条复制到 Normal 模板中。Dim atEntry As AutoTextEntryFor Each atEntry In _ ActiveDocument.AttachedTemplate.AutoTextEntries Application.OrganizerCopy _ So

36、urce:=ActiveDocument.AttachedTemplate.FullName, _ Destination:=NormalTemplate.FullName, Name:=atEntry.Name, _ Object:=wdOrganizerObjectAutoTextNext atEntry037如果活动文档中含有名为“SubText”的样式，本示例将该样式复制到 C:TemplatesTemplate1.dot 中。Dim styleLoop As StyleFor Each styleLoop In ActiveDocument.Styles If styleLoop =

37、 "SubText" Then Application.OrganizerCopy Source:=ActiveDocument.Name, _ Destination:="C:TemplatesTemplate1.dot", _ Name:="SubText", _ Object:=wdOrganizerObjectStyles End IfNext styleLoop038显示各打开文档的名称。For Each aDoc In Documents aName = aName & aDoc.Name & vbCrNe

38、xt aDocMsgBox aName039查看 Documents 集合以判定名为“Report.doc”的文档是否已打开。如果该文档包含在 Documents 集合中，则激活该文档；否则，打开该文档。For Each doc In Documents If doc.Name = "Report.doc" Then found = TrueNext docIf found <> True Then Documents.Open FileName:="C:DocumentsReport.doc"Else Documents("Rep

39、ort.doc").ActivateEnd If040如果 FirstLetterExceptions 集合包含缩写“addr.”，则下列示例将其从中删除。For Each aExcept In AutoCorrect.FirstLetterExceptions If aExcept.Name = "addr." Then aExcept.DeleteNext aExcept041创建一篇新文档，然后插入所有的自动更正的首字母例外项。Documents.AddFor Each aExcept In AutoCorrect.FirstLetterExceptions

40、 With Selection .InsertAfter aExcept.Name .InsertParagraphAfter .Collapse Direction:=wdCollapseEnd End WithNext aExcept042显示与 Windows 集合的第一个窗口相关的窗格中所有的非打印字符。For Each myPane In Windows(1).Panes myPane.View.ShowAll = TrueNext myPane043设置 Windows 集合中所有窗口的视图选项。For Each myWindow In Windows With myWindow.

41、View .ShowTabs = True .ShowParagraphs = True .Type = wdNormalView End WithNext myWindow044将包含所选内容的节的格式设置为三栏。For Each.Next 循环用于显示 TextColumns 集合中每一列的宽度。Selection.PageSetup.TextColumns.SetCount NumColumns:=3For Each acol In Selection.PageSetup.TextColumns MsgBox "Width= " & PointsToInche

42、s(acol.Width)Next acol045显示活动文档中每一个域的域代码。Dim fieldLoop As FieldFor Each fieldLoop In ActiveDocument.Fields MsgBox Chr(34) & fieldLoop.Code.Text & Chr(34)Next fieldLoop046判断活动文档中是否包含一个名为“Title”的邮件合并域。Dim fieldLoop As FieldFor Each fieldLoop In ActiveDocument.MailMerge.Fields If InStr(1, field

43、Loop.Code.Text, "Title", 1) Then MsgBox "A Title merge field is in this document" End IfNext fieldLoop047如果名为“acheive”的“自动更正”词条是 AutoCorrectEntries 集合的一员，则下列示例将该词条删除。Sub DeleteAutoTextEntry() Dim aceEntry As AutoCorrectEntry For Each aceEntry In AutoCorrect.Entries If aceEntry.Na

44、me = "acheive" Then aceEntry.Delete Next aceEntryEnd Sub048为活动文档的所有超链接创建快捷方式，并将其添加到“收藏夹”文件夹。For Each myHyperlink In ActiveDocument.Hyperlinks myHyperlink.AddToFavoritesNext myHyperlink049为 Sales.doc 创建快捷方式，并将其添加至“收藏夹”文件夹。如果 Sales.doc 还未打开，本示例将从 C:Documents 文件夹打开该文档。For Each doc in Document

45、s If LCase(doc.Name) = "sales.doc" Then isOpen = TrueNext docIf isOpen <> True Then Documents.Open _ FileName:="C:DocumentsSales.doc"Documents("Sales.doc").AddToFavorites050为活动文档中第一节的每个页面添加单线型边框，然后设置每个边框到页面边缘的距离。Dim borderLoop As BorderWith ActiveDocument.Sections

46、(1) For Each borderLoop In .Borders borderLoop.LineStyle = wdLineStyleSingle borderLoop.LineWidth = wdLineWidth050pt Next borderLoop With .Borders .DistanceFrom = wdBorderDistanceFromPageEdge .DistanceFromTop = 20 .DistanceFromLeft = 22 .DistanceFromBottom = 20 .DistanceFromRight = 22 End WithEnd Wi

47、th051为所选内容的第一节的每个页面添加边框，然后将文本与页面边框的距离设置为 6 磅。Dim borderLoop As BorderWith Selection.Sections(1) For Each borderLoop In .Borders borderLoop.ArtStyle = wdArtSeattle borderLoop.ArtWidth = 22 Next borderLoop With .Borders .DistanceFrom = wdBorderDistanceFromText .DistanceFromTop = 6 .DistanceFromLeft =

48、6 .DistanceFromBottom = 6 .DistanceFromRight = 6 End WithEnd With052如果文档在上次保存后进行了修改，本示例将保存该文档。Dim docLoop As DocumentFor Each docLoop In Documents If docLoop.Saved = False Then docLoop.SaveNext docLoop053先将文档的左右边距设置为 0.5 英寸，然后打印所有打开的文档。Dim docLoop As DocumentFor Each docLoop In Documents With docLoo

49、p .PageSetup.LeftMargin = InchesToPoints(0.5) .PageSetup.RightMargin = InchesToPoints(0.5) .PrintOut End WithNext docLoop054删除活动文档正文和页脚中的所有域。For Each aField in ActiveDocument.Fields aField.DeleteNext aFieldSet myRange = ActiveDocument.Sections(1).Footers _ (wdHeaderFooterPrimary).RangeFor Each aFiel

50、d In myRange.Fields aField.DeleteNext aField055将底纹应用于选定内容中每张表格的首行。For Each.Next 循环用于在选定内容的每张表格中循环。Sub ShadeAllFirstRowsInTables() Dim tblTable As Table If Selection.Tables.Count >= 1 Then For Each tblTable In Selection.Tables tblTable.Rows(1).Shading.Texture = wdTexture30Percent Next tblTable End

51、 IfEnd Sub056在安装的转换器中循环，如果发现 WordPerfect 6.0 转换器，本示例会使用该转换器保存活动文档。Sub SaveWithConverter() Dim cnvWrdPrf As FileConverter 'Look for WordPerfect file converter 'And save document using the converter 'For the FileFormat converter value For Each cnvWrdPrf In Application.FileConverters If cnvWrdPrf.ClassName = "WrdPrfctWin" Then ActiveDocument.SaveAs FileName:=&quo