Attribute VB_Name = "CheckPageFill"
' Heuristic check for half-empty pages inside an unfinished section (MIREA method guide, app. V).
' Run from Word: Tools → Macro → Macros → CheckPageFill_Run
' Findings may be FALSE POSITIVES (large figures, end of subsection, odd breaks).

Option Explicit

Private Const EMPTY_THRESHOLD As Double = 0.4

Public Sub CheckPageFill_Run()
    Dim doc As Document
    Dim i As Long, n As Long
    Dim msg As String
    Dim issues As Long
    Dim secTitle As String, nextTitle As String
    Dim emptyFrac As Double
    Dim contentBottom As Double
    Dim textH As Double, topM As Double, pageH As Double
    Dim rng As Range
    Dim vpos As Double

    Set doc = ActiveDocument
    doc.Repaginate
    n = doc.ComputeStatistics(wdStatisticPages)
    issues = 0
    msg = "Проверка полупустых страниц (эвристика; возможны ложные срабатывания)" & vbCrLf

    For i = 1 To n
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i
        If Selection.Sections(1).PageSetup.Orientation = wdOrientLandscape Then GoTo NextPage

        pageH = Selection.Sections(1).PageSetup.PageHeight
        topM = Selection.Sections(1).PageSetup.TopMargin
        textH = pageH - topM - Selection.Sections(1).PageSetup.BottomMargin
        If textH <= 0 Then GoTo NextPage

        Set rng = doc.Bookmarks("\page").Range
        On Error Resume Next
        vpos = rng.Information(wdVerticalPositionRelativeToPage)
        On Error GoTo 0
        contentBottom = (vpos - topM) / textH
        If contentBottom < 0 Then contentBottom = 0
        If contentBottom > 1 Then contentBottom = 1
        emptyFrac = 1# - contentBottom

        If emptyFrac <= EMPTY_THRESHOLD Then GoTo NextPage
        If i = n Then GoTo NextPage

        secTitle = HeadingNear(doc, rng.Start)
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1
        nextTitle = HeadingNear(doc, Selection.Start)
        If StrComp(secTitle, nextTitle, vbTextCompare) <> 0 Then GoTo NextPage
        If InStr(1, UCase$(secTitle), "СОДЕРЖАНИЕ", vbTextCompare) > 0 Then GoTo NextPage

        issues = issues + 1
        msg = msg & "стр. " & i & ": пустой низ ~" & Format(emptyFrac, "0%") & _
              ", раздел «" & secTitle & "» продолжается" & vbCrLf
NextPage:
    Next i

    If issues = 0 Then
        MsgBox msg & vbCrLf & "Замечаний нет.", vbInformation
    Else
        MsgBox msg & vbCrLf & "Всего: " & issues & " (эвристика).", vbExclamation
    End If
End Sub

Private Function HeadingNear(doc As Document, pos As Long) As String
    Dim p As Paragraph
    Dim s As String
    On Error Resume Next
    Set p = doc.Range(pos, pos).Paragraphs(1)
    Dim k As Long
    For k = 1 To 80
        s = p.Style
        If InStr(1, s, "Heading 1", vbTextCompare) > 0 Or InStr(1, s, "Заголовок 1", vbTextCompare) > 0 Then
            HeadingNear = Replace(Trim$(p.Range.Text), vbCr, "")
            Exit Function
        End If
        If p.Range.Start <= 1 Then Exit For
        Set p = p.Previous
        If p Is Nothing Then Exit For
    Next k
    HeadingNear = ""
End Function