Consulting

Results 1 to 18 of 18

Thread: Remove surplus spaces

  1. #1
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location

    Remove surplus spaces

    I have a macro as per the attached .docm containing also the sample text.
    It removes improper returns that have been left by OCRing documents. I am ok with the macro as is except the excess spaces. In the example it asks you to confirm the action on the 3 places highlighted. When complete you will notice that there are in some cases excess spaces between the two highlighted words. Is it possible to deal with these as part of the macro? I have made the macro to focus on just replacing the Chr(13), so that you don't get format bleed that would normally happen on a search and replace.

    Public Sub FixOCR_Returns_Click()
    Dim oRng       As Range
    Set oRng = ActiveDocument.Content
    Set oRng = Selection.Range
    
    
    Selection.Find.ClearFormatting
    With oRng.Find
        .Text = "([A-Z0-9a-z\-,’;:'\) " & ChrW(880) & "-" & ChrW(8190) & _
                "]{1,3})^13([ A-Za-z'""""0-9‘(" & ChrW(880) & "-" & ChrW(8190) & "]{1,2})"
    
    
        .MatchWildcards = True
        .Font.Superscript = False
    
    
        Do While .Execute
            oRng.Select
            'Call SelectionScrollIntoMiddleOfView
            Select Case MsgBox("Replace " & oRng & "?", vbYesNoCancel)
    
    
                Case vbYes:
                    oRng.MoveEndUntil Chr(13), wdBackward
                    oRng.MoveStartWhile Chr(13)
                    oRng.MoveStartUntil Chr(13)
                    oRng.Select
                    oRng.Text = Replace(oRng.Text, Chr(13), " ")
    
    
                    oRng.Collapse wdCollapseEnd
                Case vbNo:
                    oRng.Collapse wdCollapseEnd
                Case Else
                    Selection.Collapse wdCollapseStart
                    Exit Sub
            End Select
    
    
        Loop
        MsgBox ("No more matches found")
    End With
    lbl_Exit:
    Exit Sub
    
    
    End Sub
    Attached Files Attached Files

  2. #2
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Public Sub FixOCR_Returns_Click()
    Dim oRng       As Range
      Set oRng = Selection.Range
      Selection.Find.ClearFormatting
      With oRng.Find
        .Text = "([A-Z0-9a-z\-,’;:'\) " & ChrW(880) & "-" & ChrW(8190) & _
                "]{1,3})^13([ A-Za-z'""""0-9‘(" & ChrW(880) & "-" & ChrW(8190) & "]{1,2})"
    
        .MatchWildcards = True
        .Font.Superscript = False
        Do While .Execute
          oRng.Select
          'Call SelectionScrollIntoMiddleOfView
          Select Case MsgBox("Replace " & oRng & "?", vbYesNoCancel)
            Case vbYes:
              oRng.Text = Replace(oRng.Text, Chr(13), "")
              Do While InStr(oRng.Text, "  ") > 0
                oRng.Text = Replace(oRng.Text, "  ", " ")
              Loop
              oRng.Collapse wdCollapseEnd
            Case vbNo:
              oRng.Collapse wdCollapseEnd
            Case Else
              Selection.Collapse wdCollapseStart
              Exit Sub
          End Select
        Loop
        MsgBox ("No more matches found")
      End With
    lbl_Exit:
      Exit Sub
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  3. #3
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location
    Thanks for that but notice on the second and third highlighted word after the macro is run.The bold has bled through to the next word. This what I was trying to avoid with what I had done.

  4. #4
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Seems like a shell game with ranges. This works with your example, but I had to change your search string a little

    Public Sub FixOCR_Returns_Click()
    Dim oRng As Range
    Set oRng = Selection.Range
    Selection.Find.ClearFormatting
    With oRng.Find
    .Text = "([A-Z0-9a-z\-,’;:'\) " & ChrW(880) & "-" & ChrW(8190) & _
    "]{1})^13([ A-Za-z'""""0-9‘(" & ChrW(880) & "-" & ChrW(8190) & "]{1,2})"

    .MatchWildcards = True
    .Font.Superscript = False
    Do While .Execute
    oRng.Select
    'Call SelectionScrollIntoMiddleOfView
    Select Case MsgBox("Replace " & oRng & "?", vbYesNoCancel)
    Case vbYes:
    Do While oRng.Characters.First = " " And oRng.Characters.First.Previous = " "
    oRng.MoveStart wdCharacter, -1
    Loop
    Do Until oRng.Characters.First = " " Or oRng.Characters.First = Chr(13)
    oRng.MoveStart wdCharacter, 1
    Loop
    Do Until oRng.Characters.Last = " " Or oRng.Characters.Last = Chr(13)
    oRng.MoveEnd wdCharacter, -1
    Loop
    oRng.Select
    oRng.Text = " "

    oRng.Collapse wdCollapseEnd
    Case vbNo:
    oRng.Collapse wdCollapseEnd
    Case Else
    Selection.Collapse wdCollapseStart
    Exit Sub
    End Select
    Loop
    MsgBox ("No more matches found")
    End With
    lbl_Exit:
    Exit Sub
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  5. #5
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location
    Thanks, that has solved that issue, no bleed or excess spaces. That will be a better result.

  6. #6
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location
    I just encountered some really bad ocr that has multiple spaces at the end of a line and at the start of the next. This is just a tweak of my first macro but it no longer needs the (1,3) in the search.
    It appears to soak up the spaces ok no matter how many there are before or after. ^13 Also does not appear to bleed formatting.
    Probably don't need the green lines....No it is better to leave those in.
    Private Sub CommandButton64TEST_Click()Dim oRng       As Range
    Set oRng = ActiveDocument.Content
    If CheckBox16WholeDocumentSearch.Value = True Then
        selection.EndKey Unit:=wdStory, Extend:=wdExtend
    Else
        Set oRng = selection.Range
    End If
    
    
    selection.Find.ClearFormatting
    With oRng.Find
    
    
        .text = "([A-Z0-9a-z\-,’;:'\) " & ChrW(880) & "-" & ChrW(8190) & _
                "]{3,})^13([ A-Za-z'""""0-9‘(" & ChrW(880) & "-" & ChrW(8190) & "]{1,2})"
    
    
        .MatchWildcards = True
        '.Font.Bold = False
        .Font.Superscript = False
    
    
        Do While .Execute
            oRng.Select
            Call SelectionScrollIntoMiddleOfView
            Select Case MsgBox("Replace " & oRng & "?", vbYesNoCancel)
    
    
                Case vbYes:
                    oRng.MoveEndUntil Chr(13), wdBackward
                    oRng.MoveStartWhile Chr(13)
                    oRng.MoveStartUntil Chr(13)
                    oRng.Select
                    oRng.text = Replace(oRng.text, Chr(13), " ")
    
    
                    selection.Expand
                    selection.MoveStartUntil " "
                    selection.Range.Delete
                    selection.Range.InsertAfter " "
    
    
                    oRng.Collapse wdCollapseEnd
    
    
                Case vbNo:
                    oRng.Collapse wdCollapseEnd
                Case Else
                    selection.Collapse wdCollapseStart
                    Exit Sub
            End Select
    
    
        Loop
        MsgBox ("No more matches found")
    End With
    lbl_Exit:
    Exit Sub
    
    
    End Sub
    Last edited by JPG; 12-12-2020 at 05:32 AM.

  7. #7
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Other than perhaps the interactivity, I'm not sure you're achieving anything more than:
    Sub Demo()Application.ScreenUpdating = False
    With ActiveDocument.Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Format = False
        .Wrap = wdFindContinue
        .MatchWildcards = True
        .Replacement.Text = " "
        .Text = "[ ]{1,}^13[ ]{1,}"
        .Execute Replace:=wdReplaceAll
        .Text = "^13[ ]{1,}"
        .Execute Replace:=wdReplaceAll
        .Text = "[ ]{1,}^13"
        .Execute Replace:=wdReplaceAll
      End With
    End With
    Application.ScreenUpdating = True
    End Sub
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  8. #8
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location
    The interactivity is key to this particular macro, along with searching for valid cases to consider.
    I need to think about this some more...
    I found it was picking up legitimate things more that is should, so changing

        .text = "([A-Z0-9a-z\-,’;:'\) " & ChrW(880) & "-" & ChrW(8190) & _
                "]{1,3})^13([ A-Za-z'""""0-9‘(" & ChrW(880) & "-" & ChrW(8190) & "]{1,2})"
    To

        .text = "([A-Z0-9a-z\-,’;:'\) " & ChrW(880) & "-" & ChrW(8190) & _
                "]{3,})^13([ A-Za-z'""""0-9‘(" & ChrW(880) & "-" & ChrW(8190) & "]{1,2})"
    Is an improvement.
    Last edited by JPG; 12-12-2020 at 05:28 AM.

  9. #9
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    I don't really know exactly what you are trying to do, but it seems the issue is a paragraph mark either preceded by or followed by one or more spaces. Perhaps:

    Private Sub CommandButton64TEST_Click()Dim oRng As Range
    Dim oRngShow As Range
    Dim bWholeDoc As Boolean
    
    
    bWholeDoc = True
    Set oRng = ActiveDocument.Content
    If Not bWholeDoc Then Set oRng = Selection.Range
    Selection.Find.ClearFormatting
    With oRng.Find
      .Text = Chr(13)
      .Font.Superscript = False
      Do While .Execute
        On Error GoTo Err_GetOut
        If oRng.Characters.First.Previous = " " Or oRng.Characters.Last.Next = " " Then
          Set oRngShow = oRng.Duplicate
          oRngShow.MoveStart wdWord, -3
          oRngShow.MoveEnd wdWord, 3
          oRngShow.Select
          ActiveWindow.ScrollIntoView Selection.Range
          Select Case MsgBox("Do you want to close up this break?", vbYesNoCancel)
            Case vbYes:
              Do Until oRng.Characters.First.Previous <> " "
                oRng.MoveStart wdCharacter, -1
              Loop
              Do Until oRng.Characters.Last.Next <> " "
                oRng.MoveEnd wdCharacter, 1
              Loop
              oRng.Text = " "
              oRng.Collapse wdCollapseEnd
            Case vbNo:
              oRng.Collapse wdCollapseEnd
            Case Else
              Exit Do
          End Select
        End If
      Loop
    End With
    lbl_Exit:
    Selection.Collapse wdCollapseStart
    oRng.Collapse wdCollapseEnd
    Exit Sub
    Err_GetOut:
    MsgBox ("No more matches found")
    Resume lbl_Exit
    End Sub
    Last edited by macropod; 12-12-2020 at 11:53 AM. Reason: Repaired code tags & formatting
    Greg

    Visit my website: http://gregmaxey.com

  10. #10
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Quote Originally Posted by JPG View Post
    The interactivity is key to this particular macro, along with searching for valid cases to consider.
    That's all very well (and was obviously understood), but it fails to address the issue I raised. Try:
    Sub Demo()
    Dim Rslt
    With ActiveDocument.Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[^13]{1,}"
        .Replacement.Text = ""
        .Forward = True
        .Format = False
        .Wrap = wdFindStop
        .MatchWildcards = True
      End With
      Do While .Find.Execute
        If .End < ActiveDocument.Range.End Then
          Do While .Characters.Last.Next Like "[ " & vbCr & "]"
            If .End = ActiveDocument.Range.End Then Exit Do
            .End = .End + 1
          Loop
        End If
        If .Start > ActiveDocument.Range.Start Then
          Do While .Characters.First.Previous = " "
            If .Start = ActiveDocument.Range.Start Then Exit Do
            .Start = .Start - 1
          Loop
        End If
        If .End = ActiveDocument.Range.End Then
          If Len(.Text) = 1 Then Exit Sub
        End If
        .Select
        Rslt = MsgBox("Replace this instance?", vbYesNoCancel)
        Select Case Rslt
          Case Is = vbYes
            If .End = ActiveDocument.Range.End Then
              .Text = ""
            ElseIf .Start = ActiveDocument.Range.Start Then
              .Text = ""
            Else
              .Text = " "
            End If
          Case Is = vbCancel: Exit Sub
        End Select
        If .End = ActiveDocument.Range.End Then Exit Sub
        .Collapse wdCollapseEnd
      Loop
    End With
    End Sub
    In addition to dealing with simple excess spaces, the above code also deals with excess spaces interspersed with paragraph breaks.
    Last edited by macropod; 12-12-2020 at 12:43 PM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  11. #11
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Paul,

    I'm still not sure of the exact objective but I think the OP is trying to show some sort of span left and right of the offending spaces. I've tried to pull your code and mine together as one. ???

    Sub Demo()
    Dim oRng As Range
    Dim oRngShow As Range
    Dim bWholeDoc As Boolean
    Dim lngIndex As Long, lngSpanLR As Long
      lngSpanLR = 3
      bWholeDoc = True
      Set oRng = ActiveDocument.Content
      If Not bWholeDoc Then Set oRng = Selection.Range
      Selection.Find.ClearFormatting
      With oRng.Find
        .Text = Chr(13) & "{1,}"
        .MatchWildcards = True
        Do While .Execute
          With oRng
            If .End < ActiveDocument.Range.End Then
              Do While oRng.Characters.Last.Next Like "[ " & vbCr & "]" And .End <> ActiveDocument.Range.End
                .End = .End + 1
              Loop
            End If
            If .Start > ActiveDocument.Range.Start Then
              Do While .Characters.First.Previous = " " And .Start <> ActiveDocument.Range.Start
                .Start = .Start - 1
              Loop
            End If
            Set oRngShow = .Duplicate
            On Error Resume Next
            For lngIndex = 1 To lngSpanLR
              oRngShow.MoveStart wdWord, -1
              oRngShow.MoveEnd wdWord, 1
            Next lngIndex
            On Error GoTo 0
            Select Case True
              Case .End = ActiveDocument.Range.End And Len(.Text) = 1
              Case Else
                oRngShow.Select
                Select Case MsgBox("Remove break at this location?", vbYesNoCancel)
                  Case Is = vbYes
                    If .End = ActiveDocument.Range.End Then
                      .Text = ""
                    ElseIf .Start = ActiveDocument.Range.Start Then
                      .Text = ""
                    Else
                      .Text = " "
                    End If
                  Case Is = vbCancel: Exit Sub
                End Select
            End Select
            Selection.Collapse wdCollapseEnd
            .Collapse wdCollapseEnd
            If .End + 1 = ActiveDocument.Range.End Then Exit Do
          End With
        Loop
      End With
      MsgBox "There are no more surplus space/breaks found.", vbOKOnly, "COMPLETE"
    End Sub
    Last edited by gmaxey; 12-13-2020 at 10:34 AM.
    Greg

    Visit my website: http://gregmaxey.com

  12. #12
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Hi Greg,

    My approach to that would be:
    Sub Demo()
    Dim MsgRng As Range, Rslt As Variant
    With ActiveDocument.Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[^13]{1,}"
        .Replacement.Text = ""
        .Forward = True
        .Format = False
        .Wrap = wdFindStop
        .MatchWildcards = True
      End With
      Do While .Find.Execute
        If .End < ActiveDocument.Range.End Then
          Do While .Characters.Last.Next Like "[ " & vbCr & "]"
            If .End = ActiveDocument.Range.End Then Exit Do
            .End = .End + 1
          Loop
        End If
        If .Start > ActiveDocument.Range.Start Then
          Do While .Characters.First.Previous = " "
            If .Start = ActiveDocument.Range.Start Then Exit Do
            .Start = .Start - 1
          Loop
        End If
        If .End = ActiveDocument.Range.End Then
          If Len(.Text) = 1 Then Exit Sub
        End If
        Set MsgRng = .Duplicate
        With MsgRng
          .MoveStart wdWord, -1
          .MoveEnd wdWord, 1
          .Select
        End With
        Rslt = MsgBox("Replace this instance?", vbYesNoCancel)
        Select Case Rslt
          Case Is = vbYes
            If .End = ActiveDocument.Range.End Then
              .Text = ""
            ElseIf .Start = ActiveDocument.Range.Start Then
              .Text = ""
            Else
              .Text = " "
            End If
          Case Is = vbCancel: Exit Sub
        End Select
        If .End = ActiveDocument.Range.End Then Exit Sub
        .Collapse wdCollapseEnd
      Loop
    End With
    End Sub
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  13. #13
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Paul,

    I looks like our methods are similar. I had just assumed that trying to move three words to the left or right would have err'd if they didn't exists thus the error handler. Also addressed the possible issue of non-breaking Chr(160) spaces:

    Sub Demo()
    Dim oRng As Range
    Dim oRngShow As Range
    Dim bWholeDoc As Boolean
      bWholeDoc = True
      Set oRng = ActiveDocument.Content
      If Not bWholeDoc Then Set oRng = Selection.Range
      Selection.Find.ClearFormatting
      With oRng.Find
        .Text = Chr(13) & "{1,}"
        .MatchWildcards = True
        Do While .Execute
          With oRng
            If .End < ActiveDocument.Range.End Then
              Do While oRng.Characters.Last.Next Like "[" & Chr(32) + Chr(160) + vbCr & "]" And .End <> ActiveDocument.Range.End
                .End = .End + 1
                If .End = ActiveDocument.Range.End Then Exit Do
              Loop
            End If
            If .Start > ActiveDocument.Range.Start Then
              Do While .Characters.First.Previous Like "[" & Chr(32) + Chr(160) & "]"
                .Start = .Start - 1
                If .Start = ActiveDocument.Range.Start Then Exit Do
              Loop
            End If
            Set oRngShow = .Duplicate
            oRngShow.MoveStart wdWord, -3
            oRngShow.MoveEnd wdWord, 3
            oRngShow.Select
            Select Case MsgBox("Remove break at this location?", vbYesNoCancel)
              Case Is = vbYes
                If .End = ActiveDocument.Range.End Or .Start = ActiveDocument.Range.Start Then
                  .Text = ""
                Else
                  .Text = " "
                End If
              Case Is = vbCancel: Exit Sub
            End Select
            Selection.Collapse wdCollapseEnd
            .Collapse wdCollapseEnd
            If .End + 1 = ActiveDocument.Range.End Then Exit Do
          End With
        Loop
      End With
      MsgBox "There are no more surplus space/breaks found.", vbOKOnly, "COMPLETE"
    lbl_Exit:
      Exit Sub
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  14. #14
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Quote Originally Posted by gmaxey View Post
    I looks like our methods are similar.
    Indeed they are.
    Quote Originally Posted by gmaxey View Post
    the possible issue of non-breaking Chr(160) spaces
    I'm not aware of any OCR output (which is what we're dealing with here) that introduces non-breaking spaces into a document. If that is a real possibility, the Chr(160) spaces aren't the only ones that might need consideration.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  15. #15
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location
    Thank you Greg and Paul.
    My original macro was made with the intent of trying to skip over the cases that normally would not be an issue, like where a paragraph ends with a full stop, or if there was bold text, due to a heading etc. The issue that I encountered was the replacement leaving double spaces and the format bleed. Both these things you have fixed and so as it is it works just fine for current task.

    However the latter macro would be one I would use on a different job, that perhaps did not include footnote and page numbers that are left in the ocr text that have to be dealt with as I went along....
    I have another version where I can choose to add punctuation to include at runtime taken from a textbox on my form..
    So for me it is using the macro for the job, and I find each has their use and flexibility.
    It is also beneficial to set bWholeDoc = False so that it will start at cursor position.

    I am sure these macros will be helpful to others.

    Dim bWholeDoc As Boolean  bWholeDoc = False
      Set oRng = ActiveDocument.Content
      If Not bWholeDoc Then Set oRng = selection.Range

    Also I found it beneficial to add a screen scroll on find to the macro

    With oRng.Find    .text = Chr(13) & "{1,}"
        .MatchWildcards = True
        Do While .Execute
          With oRng
          Call SelectionScrollIntoMiddleOfView
            If .End < ActiveDocument.Range.End Then
              Do While oRng.Characters.Last.Next Like "[" & Chr(32) + Chr(160) + vbCr & "]" And .End <> ActiveDocument.Range.End
                .End = .End + 1
                If .End = ActiveDocument.Range.End Then Exit Do
              Loop
            End If

    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

  16. #16
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Paul, if you are still following this thread, have you looked at the OP procedure to scroll the selection to the middle of the screen? Here is falls flat on its face and doesn't work at all. I've tinkered a bit with it but despite coming close, I can't get the selection dead center (plus or minus a line) of the active window. I've tested with single line of text selected and multiple lines. Have you got a better idea?

    Sub SelectionScrollIntoMiddleOfView()
    Dim lngLeft As Long, lngTop As Long, lngWidth As Long, lngHeight As Long
    Dim lngWinTop As Long, lngWinHgt As Long
    Dim lngScroll As Integer
    Dim lngCenter As Long, lngWinCenter As Long
    Dim lngCounter As Long
      lngWinHgt = PixelsToPoints(ActiveWindow.Height, True)
      lngWinTop = PixelsToPoints(ActiveWindow.Top, True)
      lngWinCenter = (lngWinTop + lngWinHgt) / 2
      ActiveWindow.ScrollIntoView Selection.Range
      ActiveWindow.GetPoint lngLeft, lngTop, lngWidth, lngHeight, Selection.Range
      lngCenter = (lngTop + lngHeight) / 2
      Do
        lngScroll = Sgn(lngCenter - lngWinCenter)
        ActiveWindow.SmallScroll lngScroll
        lngCounter = lngCounter + 1
        ActiveWindow.GetPoint lngLeft, lngTop, lngWidth, lngHeight, Selection.Range
        lngCenter = (lngTop + 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 lngWinCenter - lngCenter < 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
    Greg

    Visit my website: http://gregmaxey.com

  17. #17
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Hi Greg,

    I seriously doubt vertically centering the selection on the screen is advisable; that risks placing it immediately behind the message box. To my mind, adding the following two lines after '.Select' in my code is sufficient:
        ActiveWindow.LargeScroll Down:=1
        ActiveWindow.ScrollIntoView Selection.Range
    That in invariably places the selected range just above the message box, which seems pretty close to optimal to me.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  18. #18
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location
    Quote Originally Posted by macropod View Post
    Hi Greg,

    I seriously doubt vertically centering the selection on the screen is advisable; that risks placing it immediately behind the message box. To my mind, adding the following two lines after '.Select' in my code is sufficient:
        ActiveWindow.LargeScroll Down:=1
        ActiveWindow.ScrollIntoView Selection.Range
    That in invariably places the selected range just above the message box, which seems pretty close to optimal to me.
    Good point Paul, your solution is 'close to optimal'.
    The other method does have some more control over where the text will scroll to as you will have discerned in the code. As it is I have Word on one side of the screen and so this is not an issue. If I had it filling the whole screen I would change the code to have it display more at the top, so in just the two places I have put 12 instead of 2. Another tip is to double click the gap between pages as it allows the pages to flow better
    Direction = Sgn((pTop + pHeight / 2) - (wTop + wHeight / 12))  Do While Sgn((pTop + pHeight / 2) - (wTop + wHeight / 12)) = Direction And (lTop <> pTop)
    Jon

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •