请哪位大神知道如何用VBA（visual basic）代码做word索引，求代码啊。。拜托拜托。。
我也来个：需要你手动提供关键词哦....
Sub Test()
BiaoJiAll "编辑|学校" ''
End Sub
Sub BiaoJiAll(ByVal bStr As String)
''bStr为关键词，用|分割
On Error Resume Next
Dim i As Long, w1 As String, ww
ww = Split(bStr, "|")
If UBound(ww) >= 0 Then
For i = 0 To UBound(ww)
Selection.HomeKey Unit:=wdStory ''移动到开始
With Selection.Find
.ClearFormatting
.Text = ww(i)
.Execute
If .Found Then ''如果找到了则添加到索引
ActiveDocument.Indexes.MarkAllEntries Range:=Selection.Range, Entry:= _
ww(i), EntryAutoText:=ww(i), CrossReference:="", CrossReferenceAutoText _
:="", BookmarkName:="", Bold:=False, Italic:=False
End If
End With
Next
''定位到最后
Selection.EndKey Unit:=wdStory
''在文档最后插入索引
ThisDocument.Indexes.Add Range:=Selection.Range, HeadingSeparator:= _
wdHeadingSeparatorNone, Type:=wdIndexIndent, RightAlignPageNumbers:= _
True, NumberOfColumns:=2, SortBy:=wdIndexSortByStroke, IndexLanguage _
:=wdSimplifiedChinese
End If
End Sub
Dim colWords as Collection
Set colWords = New Colection
'add words you don't want to index
colWords.Add "and"
colWords.Add "you"
Dim wrd As Range
For Each wrd In ActiveDocument.Words
'only if we have 3 chars we index
If Len(Trim(wrd.Text)) > 2 Then
' prevent the field from being Indexed as well...
Dim infield As Boolean
infield = False
Dim fld As Field
For Each fld In ActiveDocument.Fields
If (wrd.Start >= fld.Code.Start And wrd.End <= fld.Code.End) Then
infield = True
Exit For 'break out
End If
Next
If (Not infield) Then
' check if we already indexed?
Dim findWord as String
findWord = LCASE(wrd.Text)
For Each cached in colWords
if cached = findWord Then
infield = True
Exit For 'break out
end If
Next
If (Not infield) Then
ActiveDocument.Indexes.MarkAllEntries Range:=wrd, Entry:=wrd.Text, _
EntryAutoText:=wrd.Text, CrossReference:="", CrossReferenceAutoText:="", _
BookmarkName:="", Bold:=False, Italic:=False
colWords.Add findWord
End If
End If
End If
Next
Sub DemoIndex()
Dim Tbl As Table
Dim r As Range
With ActiveDocument
' for each table
For Each Tbl In .Tables
' set range for paragraph before the table
Set r = Tbl.Range.Characters.First.Previous.Paragraphs.First.Range
' use text that pparagraph for Index entry
.Indexes.MarkEntry Range:=r, _
Entry:=r.Text, _
EntryAutoText:=r.Text, _
CrossReference:="", CrossReferenceAutoText:="", _
BookmarkName:="", Bold:=False, Italic:=False, Reading:=""
Set r = Nothing
' go to next table
Next
' go to end of document and make a new section
' put in text for a title/heading
With Selection
.EndKey Unit:=wdStory
.InsertBreak Type:=wdSectionBreakNextPage
.TypeText "Table List" & vbCrLf & vbCrLf
End With
' create Index listing
.Indexes.Add Range:=Selection.Range, HeadingSeparator:= _
wdHeadingSeparatorNone, Type:=wdIndexIndent, RightAlignPageNumbers:= _
False, NumberOfColumns:=2, IndexLanguage:=wdEnglishCanadian
.Indexes(1).TabLeader = wdTabLeaderDots
End With
End Sub
总有一款适合你
Sub CreateIndex()
'
' CreateIndex Macro
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(0.8)
.BottomMargin = InchesToPoints(0.8)
.LeftMargin = InchesToPoints(0.8)
.RightMargin = InchesToPoints(0.8)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.GutterPos = wdGutterPosLeft
End With
Selection.Sections(1).Headers(1).pageNumbers.Add
PageNumberAlignment:= _
wdAlignPageNumberRight, FirstPage:=True
Dim quote As String
Dim Keyword As String
Dim j As Integer
quote = """"
Dim found_key As Boolean
Dim startSearch As Long
Dim endSearch As Long
Close #1
Open "c:\boss_info_index.txt" For Input As #1
Set myRange = ActiveDocument.Content
j = 0
Do While Not EOF(1) ' Loop until end of file.
Set myRange = ActiveDocument.Content
endSearch = myRange.End
Input #1, Keyword
j = 0
With myRange.Find
.Text = Keyword
.Forward = True
.MatchWholeWord = True
.MatchCase = False
End With
While myRange.Find.Execute
myRange.Collapse wdCollapseEnd
Set myIndexEntry = myRange.Fields.Add(myRange,
Type:=wdFieldIndexEntry, _
Text:=quote & Keyword & quote)
startSearch = myRange.End
startSearch = startSearch + 7
Set myRange = ActiveDocument.Content
myRange.Start = startSearch
If startSearch endSearch - 1 Then
GoTo skip_while
End If
With myRange.Find
.Text = Keyword
.Forward = True
.MatchWholeWord = True
.MatchCase = False
End With
' this code is because I had a loop here
j = j + 1
If j 300 Then
myRange.Bold = True
Exit Do
End If
Wend
skip_while:
Loop
Close #1 ' Close file.
myRange.Start = 0
myRange.End = 0
With ActiveDocument
.Indexes.Add Range:=myRange, HeadingSeparator:= _
wdHeadingSeparatorNone, Type:=wdIndexIndent,
RightAlignPageNumbers:= _
True, NumberOfColumns:=1, IndexLanguage:=wdEnglishUS
.Indexes(1).TabLeader = wdTabLeaderDots
End With
End Sub
最简单的方法，录制宏，然后手工操作，然后查看宏就可以了
我是word2003的，这代码在我那很正常啊，没有出现错误，如果不能建立索引，是不是你输入的内容中根本就没有关键词啊。
测试方法：新开一个word，随便输入一些内容，但必须包含学校、编辑2个关键词，然后复制下面的代码到当前document的vba里，
运行test会立即看到效果的。
Sub Test()
BiaoJiAll "编辑|学校" ''
End Sub
Sub BiaoJiAll(ByVal bStr As String)
''bStr为关键词，用|分割
On Error Resume Next
Dim i As Long, w1 As String, ww
ww = Split(bStr, "|")
If UBound(ww) >= 0 Then
For i = 0 To UBound(ww)
Selection.HomeKey Unit:=wdStory ''移动到开始
With Selection.Find
.ClearFormatting
.Text = ww(i)
.Execute
If .Found Then ''如果找到了则添加到索引
ActiveDocument.Indexes.MarkAllEntries Range:=Selection.Range, Entry:= _
ww(i), EntryAutoText:=ww(i), CrossReference:="", CrossReferenceAutoText _
:="", BookmarkName:="", Bold:=False, Italic:=False
End If
End With
Next
''定位到最后
Selection.EndKey Unit:=wdStory
''在文档最后插入索引
ThisDocument.Indexes.Add Range:=Selection.Range, HeadingSeparator:= _
wdHeadingSeparatorNone, Type:=wdIndexIndent, RightAlignPageNumbers:= _
True, NumberOfColumns:=2, SortBy:=wdIndexSortByStroke, IndexLanguage _
:=wdSimplifiedChinese
End If
End Sub