RE: MS Word Tool and Management SIG

Subject: RE: MS Word Tool and Management SIG
From: "Steve Hudson" <steve -at- wright -dot- com -dot- au>
To: "TECHWR-L" <techwr-l -at- lists -dot- raycomm -dot- com>
Date: Fri, 12 Oct 2001 16:24:06 +1000

> 1. Does anyone know of a tool that will generate a list of all the words
that appear in an MS Word document? I know MS Word provides a count of the
words, but how do you see what those words are? I am wanting to use this
list to ensure that no one of the words in the document will create problems
for translation?

Ah ha - another user for my l10n tool for Word. I knew you would pop up some
day :-)

' Collect all unique words in document.
' By Steve Hudson
Sub GrabVocab()
Dim k As Long, l As Long, MyCount As Long
Dim gvWordList() As Variant
Dim s As String, gvTitle As String
Const gvDel As Variant = ""

With ActiveDocument
MyCount = .Words.Count
ReDim gvWordList(MyCount)
MyStatusBar MyCount, ""
For k = 1 To MyCount
MyStatusBar 0, "Get Word"
gvWordList(k) = LCase(.Words(k))
While Right$(gvWordList(k), 1) = " "
gvWordList(k) = Left$(gvWordList(k), Len(gvWordList(k)) - 1)

MyCount = MyCount - KillDupes(gvWordList(), gvDel)
ReDim Preserve gvWordList(MyCount)

' remove spaces from end, change case, delete entries with special
MyStatusBar MyCount, ""
For k = 1 To MyCount
MyStatusBar 0, "Validating new words."
For l = 1 To Len(gvWordList(k))
s = Mid$(gvWordList(k), l, 1)
If (s < "a" Or s > "z") And s <> "-" Then
gvWordList(k) = gvDel
Exit For
End If

MyCount = MyCount - RemoveDeleted(gvWordList(), gvDel)
ReDim Preserve gvWordList(MyCount)

MyCount = MyCount - KillDupes(gvWordList(), gvDel)
ReDim Preserve gvWordList(MyCount)

BubbleSort gvWordList()

gvTitle = .BuiltInDocumentProperties("Title") & "-Words"
.BuiltInDocumentProperties("Title") = gvTitle
End With

With Selection
.InsertAfter gvTitle

For k = 1 To MyCount
.InsertAfter gvWordList(k)
End With
End Sub

Public Sub MyStatusBar(Status As Long, MyPrompt As String)
' sets up a progressive count to use as a progress indicator through
large macros
' to set the max number or clear the status bar, call it with a positive
' to iterate, call it with a zero

Static i As Long
Static J As Long
If Status > 0 Then
J = Status
i = 0
StatusBar = ""
i = i + 1
StatusBar = MyPrompt & " " & i & " / " & J
End If
End Sub

Public Sub ResetFind()
With Selection.Find
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Replacement.Text = ""
.Text = ""
End With
End Sub

Option Explicit

Public Sub ReReplaceAll(OldText As String, NewText As String)
Dim MyFlag As Boolean

With Selection.Find
.Text = OldText
.Replacement.Text = NewText
.Wrap = wdFindContinue
MyFlag = True
While MyFlag
MyFlag = False
Selection.HomeKey unit:=wdStory
While .Execute(Replace:=wdReplaceOne) = True
MyFlag = True
End With
End Sub

Public Sub BubbleSort(AnArray() As Variant)
If UBound(AnArray) < 2 Then Exit Sub
Dim Pass As Long
Pass = 0
While BubSortPass(AnArray(), Pass)
End Sub

Private Function BubSortPass(AnArray() As Variant, Pass As Long) As Boolean
Dim k As Long
BubSortPass = False
For k = 2 To UBound(AnArray) - Pass
If AnArray(k - 1) > AnArray(k) Then
Swap AnArray(k - 1), AnArray(k)
BubSortPass = True
End If
Pass = Pass + 1
End Function

Public Function RemoveDeleted(AnArray() As Variant, DeleteMatch As Variant)
As Long
Dim k As Long
RemoveDeleted = 0
For k = 1 To UBound(AnArray)
If AnArray(k) = DeleteMatch Then
RemoveDeleted = RemoveDeleted + 1
AnArray(k - RemoveDeleted) = AnArray(k)
End If
End Function

Public Function KillDupes(AnArray() As Variant, DeleteEntry As Variant) As
Dim k As Long, l As Long, u As Long
u = UBound(AnArray)
MyStatusBar UBound(AnArray) - 1, ""
For k = 2 To u
MyStatusBar 0, "Checking for duplicates"
For l = 1 To k - 1
If AnArray(l) = AnArray(k) Then
AnArray(k) = DeleteEntry
Exit For
End If
KillDupes = RemoveDeleted(AnArray(), DeleteEntry)
End Function

Public Sub Swap(a As Variant, B As Variant)
Dim Temp As Variant
Temp = a
a = B
B = Temp
End Sub

Steve Hudson
Principal Technical Writer
Wright Technologies (Aus)
steve -at- wright -dot- com -dot- au
(612) 9518-1822
The best way to predict the future... is to create it!

Announcing new options for IPCC 01, October 24-27 in Santa Fe,
New Mexico: attend the entire event or select a single day.
For details and online registration, visit

Your monthly sponsorship message here reaches more than
5000 technical writers, providing 2,500,000+ monthly impressions.
Contact Eric (ejray -at- raycomm -dot- com) for details and availability.

You are currently subscribed to techwr-l as: archive -at- raycomm -dot- com
To unsubscribe send a blank email to leave-techwr-l-obscured -at- lists -dot- raycomm -dot- com
Send administrative questions to ejray -at- raycomm -dot- com -dot- Visit for more resources and info.

MS Word Tool and Management SIG: From: Jivah

Previous by Author: RE: Terminology question: Deprecated function
Next by Author: RE: Acceptable synonym needed
Previous by Thread: MS Word Tool and Management SIG
Next by Thread: Re: MS Word Tool and Management SIG

What this post helpful? Share it with friends and colleagues:

Sponsored Ads