[mso] Re: Word Macro to create list of acronyms

Tony,

I was pretty intrigued by your problem about acronyms and also a bit
miffed that my previous code took so long. The code below processes by
word instead of characters and is *much* quicker. It went through a 37
page document in under 3 secs. I'm not quite sure what you want to do
with acronyms that are not in "normal" style like headings and so on
but there is a mechanism here to seperate them out. I've not saved the
acronyms anywhere you can probably figure that out for yourself but I
have highlighted them in Green for not style=normal and Pink for
style=normal.

I would appreciate some feedback as to wether it works for you because
I'm using a Dutch version of word and I am *very* interested in
multilanguage VBA.

Public Sub subCountAcronyms()

Dim olWholeStory As Range*
Dim slAcronym As String
Dim dbllT As Double*
Dim rlWord As Range*
Dim llWordCount As Long*
Dim ilAcronymCount As Integer*
Dim ilChr1 As Integer*
Dim ilChr2 As Integer*
Dim ilStyleAcronymCount As Integer*
Dim rlStyle As Style
Dim rlStyles As Styles
Dim slNormalStyle As String*

Application.DisplayStatusBar = True
dbllT = Timer
Set olWholeStory = Selection.Range
olWholeStory.WholeStory

slNormalStyle =
ActiveDocument.Styles(WdBuiltinStyle.wdStyleNormal).NameLocal
llWordCount = 0
ilAcronymCount = 0
ilStyleAcronymCount = 0

' Go through the Doc word by word.
For Each rlWord In olWholeStory.Words
    StatusBar = rlWord.Text
    llWordCount = llWordCount + 1
    If Len(rlWord) > 1 Then

      ilChr2 = Asc(Mid$(rlWord.Text, 2, 1))
      Select Case ilChr2
      Case Is < 65, Is > 90
        ' 2nd Chr Not upper case.
      Case Else
          ' 2nd Chr is upper case.

        ilChr1 = Asc(Mid$(rlWord.Text, 1, 1))
        Select Case ilChr1
        Case Is < 65, Is > 90
          ' 1st Chr Not upper case.
        Case Else
          ' 1st Chr is upper case.

          ' Is the word in "normal" style?
          If rlWord.Style <> slNormalStyle Then
            ilStyleAcronymCount = ilStyleAcronymCount + 1
            rlWord.HighlightColorIndex = wdBrightGreen
          Else
            rlWord.HighlightColorIndex = wdPink
          End If

          ' Do something with the acronym.
          subWriteAcronym rlWord.Text

          ilAcronymCount = ilAcronymCount + 1
        End Select
      End Select
    End If
Next rlWord

StatusBar = Round((Timer - dbllT), 1) _
      & "secs " & llWordCount & " Words " _
      & ilAcronymCount & " Acronyms " _
      & ilStyleAcronymCount & " Acronyms not in Normal Styale "
'
**********************************************************************
*
End Sub
Public Sub subWriteAcronym(spAcronym As String)
  'MsgBox spAcronym
'
**********************************************************************
*
End Sub

Regards
Lisa


*************************************************************
You are receiving this mail because you subscribed to mso@xxxxxxxxxxxxx or 
MicrosoftOffice@xxxxxxxxxxxxxxxx

To send mail to the group, simply address it to mso@xxxxxxxxxxxxx

To Unsubscribe from this group, send an email to 
mso-request@xxxxxxxxxxxxx with the word "unsubscribe" (without the quotes) in 
the subject line.

Or, visit the group's homepage and use the dropdown menu.  This will also allow 
you to change your email settings to digest or vacation (no mail).
http://www.freelists.org/webpage/mso

To be able to use the files section for sharing files with the group, send a 
request to mso-moderators@xxxxxxxxxxxxx and you will be sent an invitation with 
instructions.  Once you are a member of the files group, you can go here to 
upload/download files:
http://www.smartgroups.com/vault/msofiles
*************************************************************

Other related posts: