VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmJerryStats 
   Caption         =   "Cursor based statistics"
   ClientHeight    =   4224
   ClientLeft      =   36
   ClientTop       =   432
   ClientWidth     =   6732
   OleObjectBlob   =   "frmJerryStats.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "frmJerryStats"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Dim ctrlRef() As Control
Dim docRecall As Document
Dim bActive As Boolean

Private Function BinSearch(varData() As Long, s As Long)
    Dim t As Variant, i As Long, l As Long, o As Long
    
    r = UBound(varData)
    i = Int(r / 2)
    l = 1
    Do
        t = varData(i)
        If t = s Then
            BinSearch = i + 1
            Exit Do
        ElseIf t < s Then
            l = i
        Else
            r = i
        End If
        o = i
        i = l + Int((r - l) / 2)
        If i = o Then
            If varData(i) < s Then
                BinSearch = i + 1
            Else
                BinSearch = i
            End If
            Exit Do
        End If
    Loop
End Function

Private Sub mpDocStats_Change()
    If bActive Then ComputeStats mpDocStats.SelectedItem.Index
End Sub

Private Sub UserForm_Initialize()
    Dim strPage As String, winDer As Window, ctrlThis As Control
    Dim iCtrl As Integer
    
    ReDim ctrlRef(Windows.Count, mpDocStats.Pages(0).Controls.Count)
    
    Set docRecall = ActiveDocument
    
    For Each winDer In Windows
        winDer.Document.Bookmarks.Add Range:=winDer.Selection.Range, Name:="RecallSelectionObject"
        strPage = "mps" & Str$(winDer.Index)
        mpDocStats.Pages.Add strPage, winDer.Document.Name
        mpDocStats.Pages("Page1").Controls.Copy
        mpDocStats.Pages(strPage).Paste
        iCtrl = 0
        For Each ctrlThis In mpDocStats.Pages(strPage).Controls
            Set ctrlRef(winDer.Index, iCtrl) = ctrlThis
            iCtrl = iCtrl + 1
        Next ctrlThis
    Next winDer
    
    mpDocStats.Pages.Remove "Page1"
    mpDocStats.Value = ActiveWindow.Index - 1
    ComputeStats ActiveWindow.Index - 1
    bActive = True
End Sub

Private Sub ComputeStats(lPage As Long)
    Dim strTitle As String, docThis As Document, winDer As Window
    Dim rngBefore As Range, rngAt As Range, rngAfter As Range, rngAll As Range
    Dim selThis As Selection
    Dim lCharsBefore As Long, lCharsAt As Long, lCharsAfter As Long
    Dim lWordsBefore As Long, lWordsAt As Long, lWordsAfter As Long
    Dim lLinesBefore As Long, lLinesAt As Long, lLinesAfter As Long
    Dim iPagesBefore As Integer, iPagesAt As Integer, iPagesAfter As Integer
    Dim rngWord As Range, strThis As String, iLPageNo As Integer, iRPageNo As Integer
    Dim lChar As Long, charThis As String, rngCount As Range
    Dim lPageLines() As Long, lPageFinalChar() As Long, iPages As Integer, iCount As Integer
        
    Application.ScreenUpdating = False
    
    strTitle = mpDocStats.Pages(lPage).Caption
    Set docThis = Documents(strTitle)
    Set winDer = Windows(lPage + 1)
    
    If winDer.Selection.Range.Start > 1 Then
        Set rngBefore = docThis.Range(docThis.Range.Start, winDer.Selection.Range.Start - 1)
    Else
        Set rngBefore = docThis.Range(docThis.Range.Start, winDer.Selection.Range.Start)
    End If
    Set rngAt = winDer.Selection.Range
    If winDer.Selection.Range.End < docThis.Range.End Then
        If winDer.Selection.Range.End = docThis.Range.End - 1 Then  'no selection apparently
            Set rngAfter = docThis.Range(winDer.Selection.Range.End, docThis.Range.End)
        Else
            Set rngAfter = docThis.Range(winDer.Selection.Range.End + 1, docThis.Range.End)
        End If
    Else
        Set rngAfter = docThis.Range(winDer.Selection.Range.End, docThis.Range.End)
    End If
    Set rngAll = docThis.Range
    Set selThis = winDer.Selection
    
    iPages = docThis.BuiltInDocumentProperties("Number of Pages")
    ReDim lPageLines(iPages), lPageFinalChar(iPages)
    If iPages > 1 Then
        For iCount = 1 To iPages - 1
            Set rngCount = rngAll.GoTo(What:=wdGoToPage, Count:=iCount + 1)
            rngCount.Move wdCharacter, -1
            lPageLines(iCount) = rngCount.Information(wdFirstCharacterLineNumber)
            lPageFinalChar(iCount) = rngCount.End
        Next iCount
    End If
    Set rngCount = rngAll
    rngCount.Start = docThis.Range.End
    lPageLines(iPages) = rngCount.Information(wdFirstCharacterLineNumber)
    lPageFinalChar(iPages) = rngCount.End
   
    iLPageNo = BinSearch(lPageFinalChar(), rngAt.Start)
    For iCount = 1 To iLPageNo
        lLinesBefore = lLinesBefore + lPageLines(iCount)
    Next iCount
    iRPageNo = BinSearch(lPageFinalChar(), rngAt.End)
    For iCount = iRPageNo To iPages
        lLinesAfter = lLinesAfter + lPageLines(iCount)
    Next iCount
    
    selThis.Collapse wdCollapseStart
    If iRPageNo <> iLPageNo Then
        Do
            selThis.Range = selThis.GoTo(What:=wdGoToLine, Which:=wdGoToRelative, Count:=1)
            If selThis.End > lPageFinalChar(iLPageNo) Then
                Exit Do
            Else
                lLinesAt = lLinesAt + 1
                lLinesBefore = lLinesBefore - 1
            End If
        Loop
        docThis.GoTo What:=wdGoToBookmark, Name:="RecallSelectionObject"
        selThis.Collapse wdCollapseEnd
        Do
            selThis.Range = selThis.GoTo(What:=wdGoToLine, Which:=wdGoToPrevious)
            If selThis.Start < lPageFinalChar(iRPageNo - 1) + 1 Then
                Exit Do
            Else
                lLinesAt = lLinesAt + 1
                lLinesAfter = lLinesAfter - 1
            End If
        Loop
        If iRPageNo - iLPageNo > 1 Then
            For iCount = iLPageNo + 1 To iRPageNo - 1
                lLinesAt = lLinesAt + lPageLines(iCount)
            Next iCount
        End If
    Else
        Do
            selThis.Range = selThis.GoTo(What:=wdGoToLine, Which:=wdGoToRelative, Count:=1)
            If selThis.End >= rngAt.End Then
                Exit Do
            Else
                lLinesAt = lLinesAt + 1
                lLinesBefore = lLinesBefore - 1
                lLinesAfter = lLinesAfter - 1
            End If
        Loop
    End If
'    docThis.Bookmarks("RecallSelectionObject").Select
    docThis.GoTo What:=wdGoToBookmark, Name:="RecallSelectionObject"
    
    ' Filtering out foreign characters before the cursor...
    lCharsBefore = rngBefore.Characters.Count
    lWordsBefore = rngBefore.Words.Count
    For Each rngWord In rngBefore.Words
        strThis = rngWord.Text
        If Asc(strThis) < 14 Then
            Select Case Asc(strThis)
                Case 13
                    lCharsBefore = lCharsBefore - 1
                    lWordsBefore = lWordsBefore - 1
                    If Asc(Right$(rngWord.Text, 1)) = 7 Then
                        lCharsBefore = lCharsBefore - 1
                    End If
                Case Else
                    lCharsBefore = lCharsBefore - 1
                    lWordsBefore = lWordsBefore - 1
            End Select
        End If
    Next rngWord
    
    ' Filtering out foreign characters after the cursor...
    lCharsAfter = rngAfter.Characters.Count
    lWordsAfter = rngAfter.Words.Count
    For Each rngWord In rngAfter.Words
        strThis = rngWord.Text
        If Asc(strThis) < 14 Then
            Select Case Asc(strThis)
                Case 13
                    lCharsAfter = lCharsAfter - 1
                    lWordsAfter = lWordsAfter - 1
                    If Asc(Right$(rngWord.Text, 1)) = 7 Then
                        lCharsAfter = lCharsAfter - 1
                    End If
                Case Else
                    lCharsAfter = lCharsAfter - 1
                    lWordsAfter = lWordsAfter - 1
            End Select
        End If
    Next rngWord
    
    lCharsAt = rngAt.Characters.Count
    If rngAt.Words.Count > 1 Then
        lWordsAt = rngAt.Words.Count
        If Left$(rngAt.Text, Len(rngAt.Words(1).Text)) <> rngAt.Words(1).Text Then
            lWordsAt = lWordsAt - 1
            rngAt.Start = rngAt.Words(2).Start
        End If
        
        If rngAt.Sentences.Count > 1 Then
            If Right$(rngAt.Text, Len(Trim$(rngAt.Words(rngAt.Words.Count).Text))) <> rngAt.Words(rngAt.Words.Count).Text Then
                lWordsAt = lWordsAt - 1
            End If
        End If
        
        Set rngWord = Selection.Range
        rngWord.End = Selection.Words(Selection.Words.Count).End
        If rngWord.End > rngAt.End Then
            If Right$(rngAt.Text, 1) <> " " Then
                If Trim$(Right$(rngAt.Text, Len(rngAt.Words(rngAt.Words.Count).Text))) <> Trim$(rngAt.Words(rngAt.Words.Count).Text) Then
                    lWordsAt = lWordsAt - 1
                    rngAt.End = Selection.Words(lWordsAt).End
                    bTrimmedOnce = True
                End If
            End If
        End If
        
        If lWordsAt < 0 Then lWordsAt = 0
    Else
        If rngAt.Text = Selection.Words(1).Text Then
            lWordsAt = 1
        End If
    End If
    
    For Each rngWord In rngAt.Words
        Select Case Asc(Right$(rngWord.Text, 1))
            Case Is < 14
                lWordsAt = lWordsAt - 1
            Case 63
                lWordsAt = lWordsAt - 1
            Case 33
                lWordsAt = lWordsAt - 1
            Case 46
                lWordsAt = lWordsAt - 1
            Case 44
                lWordsAt = lWordsAt - 1
            Case 58
                lWordsAt = lWordsAt - 1
            Case 59
                lWordsAt = lWordsAt - 1
            Case 45
                If rngWord.Text = "--" Then  'the pesky double-dash gets counted as one word
                    lWordsAt = lWordsAt - 1
                ElseIf Asc(Right$(rngWord.Text, 2)) <> 32 Then
                    lWordsAt = lWordsAt - 2  'Account for both dash and connected word
                End If
            Case 32
                Select Case Asc(Right$(rngWord.Text, 2))
                    Case 32
                        If bTrimmedOnce = False Then
                            lWordsAt = lWordsAt - 1
                        End If
                    Case 63
                        lWordsAt = lWordsAt - 1
                    Case 33
                        lWordsAt = lWordsAt - 1
                    Case 46
                        lWordsAt = lWordsAt - 1
                    Case 44
                        lWordsAt = lWordsAt - 1
                    Case 58
                        lWordsAt = lWordsAt - 1
                    Case 59
                        lWordsAt = lWordsAt - 1
                End Select
        End Select
    Next rngWord
    
    iPagesBefore = BinSearch(lPageFinalChar(), rngAt.Start)
    iPagesAfter = iPages - BinSearch(lPageFinalChar(), rngAt.End)
    iPagesAt = iRPageNo - iLPageNo
    
    ctrlRef(winDer.Index, 1).Text = Str$(docThis.Characters.Count)
    ctrlRef(winDer.Index, 2).Text = Str$(lCharsBefore + lCharsAt + lCharsAfter)
    ctrlRef(winDer.Index, 3).Text = Str$(lWordsBefore + lWordsAt + lWordsAfter)
    ctrlRef(winDer.Index, 4).Text = Str$(lLinesBefore + lLinesAt + lLinesAfter)
    ctrlRef(winDer.Index, 5).Text = Str$(docThis.Sentences.Count)
    ctrlRef(winDer.Index, 6).Text = Str$(docThis.Paragraphs.Count)
    ctrlRef(winDer.Index, 7).Text = docThis.BuiltInDocumentProperties("Number of Pages")
    
    ctrlRef(winDer.Index, 16).Text = Str$(rngBefore.Characters.Count)
    ctrlRef(winDer.Index, 17).Text = Str$(lCharsBefore)
    ctrlRef(winDer.Index, 18).Text = Str$(lWordsBefore)
    ctrlRef(winDer.Index, 19).Text = Str$(lLinesBefore)
    ctrlRef(winDer.Index, 20).Text = Str$(rngBefore.Sentences.Count)
    ctrlRef(winDer.Index, 21).Text = Str$(rngBefore.Paragraphs.Count)
    ctrlRef(winDer.Index, 22).Text = Str$(iPagesBefore)
    
    ctrlRef(winDer.Index, 32).Text = Str$(rngAt.Characters.Count)
    ctrlRef(winDer.Index, 33).Text = Str$(lCharsAt)
    ctrlRef(winDer.Index, 34).Text = Str$(lWordsAt)
    ctrlRef(winDer.Index, 35).Text = Str$(lLinesAt)
    ctrlRef(winDer.Index, 36).Text = Str$(rngAt.Sentences.Count)
    ctrlRef(winDer.Index, 37).Text = Str$(rngAt.Paragraphs.Count)
    ctrlRef(winDer.Index, 38).Text = Str$(iPagesAt)

    ctrlRef(winDer.Index, 24).Text = Str$(rngAfter.Characters.Count)
    ctrlRef(winDer.Index, 25).Text = Str$(lCharsAfter)
    ctrlRef(winDer.Index, 26).Text = Str$(lWordsAfter)
    ctrlRef(winDer.Index, 27).Text = Str$(lLinesAfter)
    ctrlRef(winDer.Index, 28).Text = Str$(rngAfter.Sentences.Count)
    ctrlRef(winDer.Index, 29).Text = Str$(rngAfter.Paragraphs.Count)
    ctrlRef(winDer.Index, 30).Text = Str$(iPagesAfter)
    
    Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Terminate()
    Dim docThis As Document
    
    docRecall.Activate
    docThis.GoTo What:=wdGoToBookmark, Name:="RecallSelectionObject"
    For Each docThis In Documents
        docThis.Bookmarks("RecallSelectionObject").Delete
    Next docThis
End Sub