Herbers Excel-Forum - das Archiv

Sub extractwordlist()
'Kleinschreibungsliste der Ausschlußworte
Const ExcludeList = "kulmbach lebensmitteltechnik"
Dim i As Integer, docname As String
Dim DocWordList As Words
Dim IdxWordList As New Collection, dWord
Set DocWordList = ActiveDocument.Words
'Application.Documents.Open
docname = ActiveDocument.Name
titel = ActiveDocument.BuiltInDocumentProperties(1)
 
On Error Resume Next
For i = 1 To DocWordList.Count
   'If dWord.Characters(1).Font.Color = 255 Then ' Nur die roten Überschriften verwenden
If DocWordList(i).Text >= "A" And DocWordList(i) <= "Z" And Len(DocWordList(i)) > 2 Then
buffer = Trim(DocWordList(i))
If InStr(1, ExcludeList, LCase(buffer)) = 0 Then
IdxWordList.Add buffer, CStr(i)
If Err.Number <> 0 Then Err.Clear
End If
End If
   'End If
Next
On Error GoTo 0
ActiveDocument.Close
If IdxWordList.Count > 1 Then
i = 0: Do: i = i + 1
Selection.TypeText Text:="    <LI> <OBJECT type=""text/sitemap"">" & vbCrLf
Selection.TypeText Text:="         <param name=""Name"" value=""" & IdxWordList(i) & """>" & vbCrLf
Selection.TypeText Text:="         <param name=""Name"" value=""" & titel & """>" & vbCrLf
Selection.TypeText Text:="         <param name=""Local"" value=""" & docname & "#" & IdxWordList(i) & i & """> </OBJECT>" & vbCrLf
Loop Until i = IdxWordList.Count
End If
End Sub