Microsoft Office Forums - View Single Post - Vertically Center Selected Range in the Useable Window

gmaxey · 12-19-2020, 10:01 AM

Any regulars here want to take a stab at this see:

Vertically Center Selected Range in the Useable ActiveWindow

There is some code floating about published by Andreas Killer about 10 years ago for centering selected text in the active window:

Code:

Sub SelectionScrollIntoMiddleOfView3() '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.ScrollIntoView Selection.Range
  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 is simply doesn't work. First it doesn't compile because of the Direction, down line but even removing the "down", it still does nothing (most of the time).

I've put some example images in the linked thread and I've managed to put this together which (for me) works better, but there is an unresolved issue if the selected text spans more than one line. For me (and on my PC and ActiveWindow), one line of selected text returns a value of 28 and I can tweak the centering to using that value. That may not work for everyone. Can't figure out how to nail the center of the selected text to the center of the active window. All suggestions welcome!!

Code:

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