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"

1.jpgImage 1
Paul simple method.jpgPaul Simple Method (result after running)
Goal.jpgGoal

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-...le-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.