Vertically Center Selected Range in the Useable ActiveWindow

[gmaxey]

There is another thread in this forum where the discussion has turned to vertically centering a selected range in the active window. The code presented is shown below:


Sub SelectionScrollIntoMiddleOfView()'https://answers.microsoft.com/en-us/msoffice/forum/msoffice_word-msoffice_custom-mso_2010/centre-selected-text-in-the-middle-of-the-screen/84ab25fe-9570-4b55-91bd-4b11a04bb99b?auth=1 Dim pLeft As Long
Dim pTop As Long, lTop As Long, wTop As Long
Dim pWidth As Long
Dim pHeight As Long, wHeight As Long
Dim Direction As Integer


wHeight = PixelsToPoints(ActiveWindow.Height, True)
ActiveWindow.GetPoint pLeft, wTop, pWidth, pHeight, ActiveWindow
ActiveWindow.GetPoint pLeft, pTop, pWidth, pHeight, selection.Range


Direction = Sgn((pTop + pHeight / 2) - (wTop + wHeight / 2))
Do While Sgn((pTop + pHeight / 2) - (wTop + wHeight / 2)) = Direction And (lTop <> pTop)
ActiveWindow.SmallScroll Direction, down
On Error Resume Next
lTop = pTop
ActiveWindow.GetPoint pLeft, pTop, pWidth, pHeight, selection.Range
Loop
End Sub

My experience here is that code simply doesn't work. First, it doesn't compile because of the "Direction, down" in the ActiveWindow.Smallscroll line. Remove ", down" from that line and it will compile but when run with the condition shown in image "1" nothing happens.

Macropod suggested two simple lines of code:

ActiveWindow.LargeScroll Down:=1
ActiveWindow.ScrollIntoView Selection.Range

However, when that is run on the condition one text the result is as shown in image "Paul Simple Method" (note the selected text
is at the top of the window (not centered in the window)

The goal is for the text to appear more like the text in image "Goal"

27582Image 1
27583Paul Simple Method (result after running)
27584Goal

Iv'e been struggling with deducing the center of the selection as compared to the center of the useable
window and moving the selection up or down as appropriate. The following gets close with the examples shown but if the selection is just a single line
of text then it ends up being a little above or below center:


Sub SelectionScrollIntoMiddleOfView()
Dim lngLeft As Long, lngTop As Long, lngWidth As Long, lngHeight As Long, lngComp As Long
Dim lngWinTop As Long, lngWinHgt As Long, lngWinUseableHgt As Long
Dim lngScroll As Integer
Dim lngCenter As Long, lngWinCenter As Long
Dim lngCounter As Long
lngWinHgt = PixelsToPoints(ActiveWindow.Height, True)
lngWinUseableHgt = PixelsToPoints(ActiveWindow.UsableHeight, True)
lngComp = lngWinHgt - lngWinUseableHgt
lngWinTop = PixelsToPoints(ActiveWindow.Top, True)
lngWinCenter = (lngWinTop + lngWinHgt) / 2
ActiveWindow.ScrollIntoView Selection.Range
ActiveWindow.GetPoint lngLeft, lngTop, lngWidth, lngHeight, Selection.Range
lngCenter = ((lngTop - lngComp) + lngHeight) / 2
lngScroll = Sgn(lngCenter - lngWinCenter)
Do
ActiveWindow.SmallScroll lngScroll
lngCounter = lngCounter + 1
ActiveWindow.GetPoint lngLeft, lngTop, lngWidth, lngHeight, Selection.Range
lngCenter = ((lngTop - lngComp) + lngHeight) / 2
If lngScroll > 0 Then
If lngCenter > lngWinCenter Then
If lngCenter - lngWinCenter < 10 Then Exit Do
Else
If lngWinCenter - lngCenter < 10 Then Exit Do
End If
Else
If lngCenter > lngWinCenter Then
If lngCenter - lngWinCenter > 10 Then Exit Do
Else
If lngWinCenter - lngCenter < 10 Then Exit Do
End If
End If
If lngCounter > 20 Then Exit Do
Loop
lbl_Exit:
Exit Sub
End Sub



Interested if anyone has ideas to improve this process. Paul, I understand the concerns you raised about centering and message boxes.
This is not related to displaying a message box. Just a process of trying to do something that should be able to be done ;-)

[gmaxey]

Also posted at: https://www.msofficeforums.com/word-vba/46191-vertically-center-selected-range-useable-window.html

A plethora of interest here LOL. Well I've made some progress and simplified things a little:


Sub SelectionScrollIntoMiddleOfView()
Dim lngLeft As Long, lngTop As Long, lngWidth As Long, lngHeight As Long
Dim lngWinTop As Long, lngWinUseableHgt As Long
Dim lngScroll As Integer
Dim lngCenter As Long, lngWinCenter As Long
Dim lngCenAdj As Long, lngIndex As Long '***
lngWinUseableHgt = ActiveWindow.UsableHeight
lngWinTop = ActiveWindow.Top
lngWinCenter = (lngWinTop + lngWinUseableHgt + 1) / 2
ActiveWindow.ScrollIntoView Selection.Range
ActiveWindow.GetPoint lngLeft, lngTop, lngWidth, lngHeight, Selection.Range
lngCenter = (lngTop + lngHeight) / 2
lngScroll = Sgn(lngCenter - lngWinCenter)
lngCenAdj = ((lngHeight / 28) - 1) / 2 '*** On my screen, a slection of one line returns 28
Do Until Abs(lngCenter - lngWinCenter) < 10
ActiveWindow.SmallScroll lngScroll
ActiveWindow.GetPoint lngLeft, lngTop, lngWidth, lngHeight, Selection.Range
lngCenter = (lngTop + lngHeight) / 2
Loop
'*** Adjust center based on height of selection
If lngCenAdj > 0 Then
For lngIndex = 1 To lngCenAdj
If lngScroll = 1 Then ActiveWindow.SmallScroll -1
If lngScroll = -1 Then ActiveWindow.SmallScroll -1
Next lngIndex
End If
lbl_Exit:
Exit Sub
End Sub

For now, if the selection is a single line of text, the code seems to cooperate quite well and center the selected text (provided of course the text is not at the top of the document where it couldn't be scrolled to center). However, if the selection is more than one line I've not been able to figure out a universal solution to determine when the scroll up or down should stop to center the selection in the center. On my PC, one line of selected text returns a height value of 28. Without some sort of adjustment, selections of two lines or more the result was that the bottom of the slection was centered. There doesn't seem to be any direct correlation to Window Center and Selection Center. I've cobbled together a process to account for this issue on my PC but not sure how it would work for others.