Thread: [Solved] Word Count Macro
View Single Post
 
Old 08-01-2017, 07:19 AM
gmaxey gmaxey is offline Windows 7 32bit Office 2016
Expert
 
Join Date: May 2010
Location: Brasstown, NC
Posts: 1,600
gmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nice
Default

mana,

You seem to have a good handle on dictionaries ;-)

If we conclude that a word is something that is delimited in a document by white space then the following may get us closer to a workable solution:

Code:
Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey, http://gregmaxey.com/word_tips.html, 8/1/2017
Dim oWord As Range
Dim oRng As Word.Range
Dim lngCount As Long
Dim lngIndex As Long
Dim lngMark As Long
  
  lngCount = InputBox("Enter the number of words to count", "Word Count", "25")
   With ActiveDocument
    For lngIndex = .Comments.Count To 1 Step -1
      If InStr(.Comments(lngIndex).Range.Text, "[Word Count:") > 0 Then
        .Comments(lngIndex).Delete
      End If
    Next
    Set oRng = ActiveDocument.Range
  End With
  lngMark = 0
  Do
    For Each oWord In oRng.Words
      If oWord.InRange(oRng) Then
        If Not fcnIsWhiteSpace(oWord) Then
          lngIndex = lngIndex + 1
          Do Until fcnIsWhiteSpace(oWord.Characters.Last) Or fcnIsWhiteSpace(oWord.Characters.Last.Next)
            oWord.MoveEnd wdWord, 1
            oRng.Start = oWord.Duplicate.End
          Loop
          Do While fcnIsWhiteSpace(oWord.Characters.Last) Or oWord.Characters.Last Like "[)}:;./?/!" & Chr(148) & "," & Chr(34) & "]"
            oWord.MoveEnd wdCharacter, -1
           Loop
          Do Until oWord.Characters.Last <> "]"
            oWord.MoveEnd wdCharacter, -1
          Loop
          If lngIndex = lngCount Then
            lngMark = lngMark + lngIndex
            lngIndex = 0
            oRng.Comments.Add oWord, "[Word Count: " & lngMark & "]"
          End If
        End If
      End If
    Next
  Loop Until oRng.End = ActiveDocument.Range.End
  'Here is where we coudld convert the comments to "instring" flags as the OP requested.
'  For lngIndex = ActiveDocument.Comments.Count To 1 Step -1
'    If Left(ActiveDocument.Comments(lngIndex).Range.Text, 11) = "[Word Count" Then
'      Set oRng = ActiveDocument.Comments(lngIndex).Reference
'      oRng.InsertAfter "/"
'      ActiveDocument.Comments(lngIndex).Delete
'    End If
'  Next
lbl_Exit:
  Exit Sub
End Sub

Private Function fcnIsWhiteSpace(oRngEndCharacter As Range) As Boolean
  'If its nothing the it isn't whitespace!
  fcnIsWhiteSpace = False
  If Not oRngEndCharacter Is Nothing Then
    Select Case AscW(oRngEndCharacter.Text)
      Case 8194, 8195, 8197, 9, 11, 13, 32, 160: fcnIsWhiteSpace = True
    End Select
  End If
End Function
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote