向上或向下移动时突出显示当前 Word 文档行

Question

我想开发一个程序，当向上或向下箭头移动时，突出显示整行文本。因此，当我使用箭头键向上或向下时，它会突出显示光标所在的行。

所以我开发了这段代码。

Application.ScreenUpdating = False

Dim currentPosition As Range
Set currentPosition = Selection.Range 'pick up current cursor position

Selection.WholeStory
Selection.Range.HighlightColorIndex = wdNoHighlight


currentPosition.Select 'return cursor to original position

Selection.Range.HighlightColorIndex = wdYellow

Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend

Selection.Range.HighlightColorIndex = wdYellow

'Unselect the line
Application.Selection.EndOf

Application.ScreenUpdating = True

然后我尝试将此宏分配给向上箭头键和向下箭头键。然后我意识到我们不能为 2 个组合键分配一个宏。所以我创建了 2 个这样的宏。 （内容相同。只是名称不同。）。 并将 SelectLineUp 分配给向上箭头键并将 SelectLineDown 分配给向下箭头键。

Sub SelectLineUp()

Application.ScreenUpdating = False

Dim currentPosition As Range
Set currentPosition = Selection.Range 'pick up current cursor position

Selection.WholeStory
Selection.Range.HighlightColorIndex = wdNoHighlight


currentPosition.Select 'return cursor to original position

Selection.Range.HighlightColorIndex = wdYellow

Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend

Selection.Range.HighlightColorIndex = wdYellow

'Unselect the line
Application.Selection.EndOf


Application.ScreenUpdating = True


End Sub

这是向下箭头

Sub SelectLineDown()

Application.ScreenUpdating = False

Dim currentPosition As Range
Set currentPosition = Selection.Range 'pick up current cursor position

Selection.WholeStory
Selection.Range.HighlightColorIndex = wdNoHighlight


currentPosition.Select 'return cursor to original position

Selection.Range.HighlightColorIndex = wdYellow

Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend

Selection.Range.HighlightColorIndex = wdYellow

'Unselect the line
Application.Selection.EndOf

Application.ScreenUpdating = True

End Sub

现在的问题是，当我按下键盘中的向下箭头时，它会按我的预期工作。但是当我按向上箭头时，它仍然会在文档中向下移动。非常感谢您能告诉我我做错了什么。

Answer 1

以下内容对我有用。我使用了一些额外的方法来更改选择（或范围）位置，例如MoveEnd、MoveStart 和Collapse。请注意整个文档的高亮设置的更改，这样您就不必更改选择。

如果您使用 F8 单步执行代码，并在 VBA 编辑器和文档窗口之间切换，您可以看到这些方法是如何工作的。详细信息可以在 VBA 帮助中找到。

Sub SelectLineUp()
    Application.ScreenUpdating = False
    ActiveDocument.content.HighlightColorIndex = wdNoHighlight

    Selection.MoveEnd wdLine, -1
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend

    Selection.Range.HighlightColorIndex = wdYellow

    'Unselect the line
    Application.Selection.StartOf
    Application.ScreenUpdating = True
End Sub

Sub SelectLineDown()
    Application.ScreenUpdating = False

    ActiveDocument.content.HighlightColorIndex = wdNoHighlight

    Selection.MoveStart wdLine, 1
    Selection.HomeKey Unit:=wdLine
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend

    Selection.Range.HighlightColorIndex = wdYellow

    'Unselect the line
    Application.Selection.Collapse wdCollapseStart

    Application.ScreenUpdating = True
End Sub

Answer 2

试试这个。这对我有用，同时保持代码非常干燥。

Option Explicit

Private Declare Function GetKeyState Lib "user32.dll" (ByVal nKey As Long) As Integer

Public Sub KeyUpOrDown()
    Dim keyUp As Boolean
    keyUp = CBool(GetKeyState(vbKeyUp) And &H80) ' Was "keyup" pressed

    If (keyUp) Then
        Selection.MoveUp Unit:=wdLine
        Call HighlightLine
    Else
        Selection.MoveDown Unit:=wdLine
        Call HighlightLine
    End If

End Sub

Private Sub HighlightLine()
    Application.ScreenUpdating = False
    Dim currPosition As Range
    Set currPosition = Selection.Range

    ActiveDocument.Content.HighlightColorIndex = wdNoHighlight
    Selection.Expand Unit:=wdLine
    Selection.Range.HighlightColorIndex = wdYellow

    currPosition.Select

End Sub

两个触发键都可以绑定到公共子例程“KeyUpOrDown”。

我喜欢这种工作方式，因为它具有原生的感觉。正如您在代码中暗示的那样，选择点不会折叠到一侧，但在切换行时会保持其原始位置。

另一个大事件是使用外部“user32.dll”库模拟按键事件。

我希望你会发现它有用。 谢谢。

Answer 3

在接受的答案中有一点性能改进。如果您有 400 页的书，则取消突出显示整个文档会花费太多时间。
此外，代码不会将您返回到相同的光标位置。 我稍微修改了代码以解决这两个问题：
将此添加到声明部分。

Dim currSelection As Range

将这些宏绑定到向上和向下键

Sub UpKey()
    Application.ScreenUpdating = False
    'get current position
    Dim currPosition As Range
    Set currPosition = Selection.Range

    'remove highlight from previous line
    If Not currSelection Is Nothing Then
        currSelection.HighlightColorIndex = wdNoHighlight
    End If
        
    'move and highlight new line
    Selection.MoveUp Unit:=wdLine
    Selection.HomeKey Unit:=wdLine
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend
    Set currSelection = Selection.Range
    Selection.Range.HighlightColorIndex = wdYellow

    'get back to old spot and move the line
    currPosition.Select
    Selection.MoveUp Unit:=wdLine
    
    Application.ScreenUpdating = True
End Sub

Sub DownKey()
 Application.ScreenUpdating = False
    Dim currPosition As Range
    Set currPosition = Selection.Range

    If Not currSelection Is Nothing Then
        currSelection.HighlightColorIndex = wdNoHighlight
    End If
        
    Selection.MoveDown Unit:=wdLine
    Selection.HomeKey Unit:=wdLine
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend
    Set currSelection = Selection.Range
    Selection.Range.HighlightColorIndex = wdYellow

    currPosition.Select
    Selection.MoveDown Unit:=wdLine
    
    Application.ScreenUpdating = True
End Sub

注意：如果由于某种原因某行保持突出显示，则将光标移至该行并向上或向下移动一次。