鼠标高亮显示的解决方法

win2009 · 发表于 2012-8-24 22:59

本帖最后由 win2009 于 2012-8-24 22:59 编辑

论坛高手的帖子，改造一下，解决显示高亮时，屏幕跟随的问题
值增加了2句代码
ActiveSheet.ScrollArea = Selection.Address
ActiveSheet.ScrollArea = ""

Option Explicit
Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Type POINTAPI
x As Long
y As Long
End Type
Dim m_blnTimerOn As Boolean
Dim m_lngTimerId As Long
Dim m_NewRange As Range
Dim m_OldRange As Range
Sub StartTimer()
If Not m_blnTimerOn Then
m_lngTimerId = SetTimer(0, 0, 0.05, AddressOf TimerProc)
m_blnTimerOn = True
' Set m_OldRange = ActiveSheet.Range("A1")
End If
End Sub
Public Function TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lngCurPos As POINTAPI
'
On Error Resume Next
GetCursorPos lngCurPos
Set m_NewRange = ActiveWindow.RangeFromPoint(lngCurPos.x, lngCurPos.y)
With m_NewRange
If m_OldRange.Address <> .Address Then
Dim r As Long, c As Long
r = .Row
c = .Column
Rows(r).Select
' Union(Columns(c), Rows(r)).Select
End If
End With
Set m_OldRange = m_NewRange
TimerProc = 0
End Function
Sub StopTimer()
If m_blnTimerOn Then
KillTimer 0, m_lngTimerId
m_blnTimerOn = False
End If
End Sub
Public Sub 开始()
ActiveSheet.ScrollArea = Selection.Address
StartTimer
End Sub
Public Sub 结束()
ActiveSheet.ScrollArea = ""
StopTimer
End Sub

复制代码

工作簿1.zip (19.29 KB, 下载次数: 159)

win2009 · 发表于 2012-8-24 23:03

发错地方，版主请移到vba论坛，谢谢

HHAAMM · 发表于 2012-8-25 00:58

不好不好要修改一句
Rows(r).Select
换成下面两句
Union(Columns(c), Rows(r)).Select
Cells(r, c).Activate

HHAAMM · 发表于 2012-8-25 01:06

为了高亮用定时器有些不值

win2009 · 发表于 2012-8-25 02:30

加载宏

鼠标经过高亮.zip (13.33 KB, 下载次数: 158)

win2009 · 发表于 2012-8-25 10:45

版主说的是，但从实用角度看这个基本上就是最快的，没有停顿的
以前看了多个版本的，虽然不乏高明之作，但没有一个中意的，
原因：就是这点小事，还需多次点击鼠标，所以一直没有用这个功能，
等待明码出现，发现这个后，也觉得有问题，这两天想了一下，觉得
把单元格区域定住就行，结果真的行了，有了这个，我觉得很方便了

只是自己的感觉，软件方便实用的基本功能，胜过用户登峰造极的本领，
我们点灯熬油，孜孜以求的目的，不是要取得微软的表扬奖励，而是要
服务于求生存，和生存过程中追求快感愉悦自身天性。

借用一下古代一个生活在社会底层的歌妓的小词说明一下对学vba的看法

卜算子
严蕊
不是爱风尘，似被前缘误。花落花开自有时，总赖东君主。
去也终须去，住也如何住！若得山花插满头，莫问奴归处。

复制代码

HHAAMM · 发表于 2012-8-25 21:34

修修改改来个钩子的，应该比定时器合理些

Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal mHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal mHook As Long, ByVal nCode As Long, ByVal wParam As Long, lparam As Any) As Long
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEMOVE = &H200
Private Type POINTAPI
x As Long
y As Long
End Type
Public mHook As Long
Public Sub StartBright()
If mHook = 0 Then
mHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf HookProc, Application.Hinstance, 0)
End If
End Sub
Public Sub EnaBright()
If mHook <> 0 Then
Call UnhookWindowsHookEx(mHook)
mHook = 0
End If
End Sub
Private Function HookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
Dim PT As POINTAPI, Rng As Excel.Range
If nCode < 0 Then
HookProc = CallNextHookEx(mHook, nCode, wParam, lparam)
Exit Function
End If
If wParam = WM_MOUSEMOVE Then
Call GetCursorPos(PT)
On Error Resume Next
Set Rng = ActiveWindow.RangeFromPoint(PT.x, PT.y)
If Not Rng Is Nothing Then
Union(Columns(Rng.Column), Rows(Rng.Row)).Select
Rng.Activate
End If
End If
End Function

复制代码

win2009 · 发表于 2012-8-25 21:41

HHAAMM 发表于 2012-8-25 21:34
修修改改来个钩子的，应该比定时器合理些

谢谢，不知道怎么回事，我复制代码是这样

Option ExplicitPrivate Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPrivate Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As LongPrivate Declare Function UnhookWindowsHookEx Lib "user32" (ByVal mHook As Long) As LongPrivate Declare Function CallNextHookEx Lib "user32" (ByVal mHook As Long, ByVal nCode As Long, ByVal wParam As Long, lparam As Any) As LongPrivate Const WH_MOUSE_LL As Long = 14Private Const WM_MOUSEMOVE = &H200Private Type POINTAPI x As Long y As LongEnd TypePublic mHook As LongPublic Sub StartBright() If mHook = 0 Then mHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf HookProc, Application.Hinstance, 0) End IfEnd SubPublic Sub EnaBright() If mHook <> 0 Then Call UnhookWindowsHookEx(mHook) mHook = 0 End IfEnd SubPrivate Function HookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As Long Dim PT As POINTAPI, Rng As Excel.Range If nCode < 0 Then HookProc = CallNextHookEx(mHook, nCode, wParam, lparam) Exit Function End If If wParam = WM_MOUSEMOVE Then Call GetCursorPos(PT) On Error Resume Next Set Rng = ActiveWindow.RangeFromPoint(PT.x, PT.y) If Not Rng Is Nothing Then Union(Columns(Rng.Column), Rows(Rng.Row)).Select Rng.Activate End If End IfEnd Function

HHAAMM · 发表于 2012-8-25 21:45

嗯可能是你浏览器的问题

win2009 · 发表于 2012-8-25 21:48

HHAAMM 发表于 2012-8-25 21:34
修修改改来个钩子的，应该比定时器合理些

是了，但屏幕还是乱跑啊，不行的，版主再改改
屏幕乱动就没用

		自动登录	找回密码
密码			免费注册

[分享] 鼠标高亮显示的 解决 方法

[分享] 鼠标高亮显示的解决方法