RE: MS Word Tool and Management SIG

["Steve Hudson" <steve -at- wright -dot- com -dot- au>]

> 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)
            Wend

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

        ' remove spaces from end, change case, delete entries with special
characters
        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
            Next
        Next

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

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

        BubbleSort gvWordList()

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

    With Selection
        .InsertAfter gvTitle
        .InsertParagraphAfter
        .InsertParagraphAfter

        For k = 1 To MyCount
            .InsertAfter gvWordList(k)
            .InsertParagraphAfter
        Next
        .Collapse
    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
number
    ' to iterate, call it with a zero

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


Public Sub ResetFind()
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .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
    ResetFind

    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
            Wend
        Wend
    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)
    Wend
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
    Next
    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
        Else
            AnArray(k - RemoveDeleted) = AnArray(k)
        End If
    Next
End Function

Public Function KillDupes(AnArray() As Variant, DeleteEntry As Variant) As
Long
    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
        Next
    Next
    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 http://ieeepcs.org/2001

  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 
http://www.raycomm.com/techwhirl/ for more resources and info.