Sub WordsForToday()
Application.ScreenUpdating = False
Dim Sctn As Section, oHdFt As HeaderFooter, lHdr As Long, lFtr As Long
Dim oEnt As Endnote, lEnt As Long, oFnt As Footnote, lFnt As Long
Dim oShp As Shape, lShp As Long
With ActiveDocument
  For Each oEnt In .Endnotes
    lEnt = lEnt + CountRevisions(oEnt.Range)
  Next
  For Each oFnt In .Footnotes
    lFnt = lFnt + CountRevisions(oFnt.Range)
  Next
  For Each Sctn In .Sections
    For Each oHdFt In Sctn.Headers
      If Not oHdFt.LinkToPrevious Then _
        lHdr = lHdr + CountRevisions(oHdFt.Range)
    Next
    For Each oHdFt In Sctn.Footers
      If Not oHdFt.LinkToPrevious Then _
        lFtr = lFtr + CountRevisions(oHdFt.Range)
    Next
  Next
  For Each oShp In .Shapes
    If Not oShp.TextFrame Is Nothing Then _
      lShp = lShp + CountRevisions(oShp.TextFrame.TextRange)
  Next
  MsgBox "Today's Word Count Statistics:" & vbCr & _
    "EndNotes - " & vbTab & lEnt & vbCr & _
    "Footnotes - " & vbTab & lFnt & vbCr & _
    "Headers - " & vbTab & vbTab & lHdr & vbCr & _
    "Footers - " & vbTab & vbTab & lFtr & vbCr & _
    "Shapes - " & vbTab & vbTab & lShp & vbCr & _
    "Other - " & vbTab & vbTab & CountRevisions(.Range)
End With
Application.ScreenUpdating = True
End Sub
 
Function CountRevisions(Rng As Range) As Long
Dim oRev As Revision, i As Long
For Each oRev In Rng.Revisions
  If Int(oRev.Date) = Date And oRev.Type = wdRevisionInsert Then
    i = i + oRev.Range.ComputeStatistics(wdStatisticWords)
  End If
Next
CountRevisions = i
End Function