Vbscript / Ms Office / Find Acronyms In Word Document
Find all acronyms in an MS Word document and create a table for definitions.
'Minimum length of acronyms
intMin = 2
'Maximum length of acronyms
intMax = 5 'hardcode document path
'strDocPath = "C: est.doc" 'Select document
Set objDialog = CreateObject("UserAccounts.CommonDialog") objDialog.Filter = "All Folders|*.doc"
objDialog.InitialDir = "C:"
intResult = objDialog.ShowOpen
If intResult = 0 Then
Wscript.Quit
Else
strDocPath = objDialog.FileName
End If
Set objAcronyms = CreateObject("Scripting.Dictionary")
Set objWord = CreateObject("Word.Application") ' Display the application.
objWord.Visible = TRUE
Set objDoc = objWord.Documents.Open(strDocPath) 'Output to IE 'Internet Explorer output window
Set objExplorer = CreateObject("InternetExplorer.Application")
objExplorer.Navigate "about:blank"
objExplorer.ToolBar = 0
objExplorer.StatusBar = 1
objExplorer.Width = 400
objExplorer.Height = 800
objExplorer.Left = 0
objExplorer.Top = 0
objExplorer.Visible = 1 Do While (objExplorer.Busy)
Loop Set objDocument = objExplorer.Document
objDocument.Open
objDocument.Writeln "<html><head><title>Acronyms</title></head>" objDocument.Writeln "<body>Finding acronyms in '" & strDocPath & "', please wait ...."
strCont = ""
Set colWords = objDoc.Words 'Loop through words in document
For Each strWord in colWords strWord = Alpha(strWord) If UCase(strWord) = strWord AND strWord <> "" AND Len(strWord) > intMin - 1 AND Len(strWord) < intMax Then If NOT objAcronyms.Exists(strWord) then objAcronyms.Add strWord,strWord End If End If
Next
objDocument.Writeln "<br/><br/>" & objAcronyms.Count & " acronyms found <br/><br/>" 'Array from dictionary
arrayItems = objAcronyms.Items
for i = 0 to objAcronyms.Count - 1
strCont = strCont & vbCRLF & "<tr><td>" & arrayItems(i) & "</td></tr>"
next
'Enter output into document
Set objSelection = objWord.Selection
'objSelection.TypeText strCont
objDocument.Writeln "<table><tr><td><b>Acronym</b></td><td><b>Definition</b></td></tr>"
objDocument.Writeln strCont & "</table></body></html>" 'objExplorer.Navigate("about:blank")
objDocument.parentwindow.clipboardData.SetData "text", strCont 'objDoc.Close
'Function to return only alphabetic characters in the supplied string i.e. not numbers, punctuation, symbols etc.
Function Alpha(theString)
For ch = 1 to Len(theString) strChar = Mid(theString,ch,1) Select Case Lcase(strChar) Case "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z" strChars = strChars & strChar Case Else End Select Alpha = strChars Next End Function
Please note that a disclaimer applies to any code on this page.
| 
