[mso] Re: Word Macro to create list of acronyms
- From: "Green" <1z@xxxxxxxxxxxxxx>
- To: <mso@xxxxxxxxxxxxx>
- Date: Tue, 24 Aug 2004 21:45:20 +0200
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).
//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:
