ption Explicit
Sub CreateAutoMarkFile()
Dim fld As Field
Dim strText As String
Dim rw As Row
Dim tbl As Table
Dim bFound As Boolean
Dim doc As Word.Document
Dim DocA As Document
Set DocA = ActiveDocument
Set doc = Documents.Add
Set tbl = doc.Tables.Add(doc.Range, 1, 2)
For Each fld In DocA.Fields
If fld.Type = wdFieldIndexEntry Then
strText = GetIndexText(fld)
bFound = False
For Each rw In tbl.Rows
If GetCellText(rw.Cells(1)) = strText Then
bFound = True
Exit For
End If
Next rw
If Not bFound Then
If Len(tbl.Rows.Last.Range) = 6 Then
Set rw = tbl.Rows.Last
Else
Set rw = tbl.Rows.Add
End If
rw.Cells(1).Range.Text = strText
rw.Cells(2).Range.Text = strText
End If
End If
Next fld
doc.SaveAs "C:\MyFolder\MyAutoMark.doc"
doc.Close wdDoNotSaveChanges
DocA.Indexes.AutoMarkEntries "C:\MyFolder\MyAutoMark.doc"
End Sub
Function GetCellText(cl As Word.Cell) As String
Dim rng As Range
Set rng = cl.Range
rng.MoveEnd wdCharacter, -1
GetCellText = rng.Text
End Function
Function GetIndexText(fld As Word.Field) As String
Dim p As Integer
Dim q As Integer
Dim strText As String
strText = fld.Code.Text
p = InStr(strText, """")
q = InStrRev(strText, """")
GetIndexText = Mid$(strText, p + 1, q - p - 1)
End Function
|