Igor20264
b38661f588
Python application / build (push) Has been cancelled
- Add\Rework UI - Add Split Table and Listing - Add Support Customazeble schems
86 lines
3.2 KiB
VB.net
86 lines
3.2 KiB
VB.net
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
|