聚光灯可以借鉴“鼠标经过高亮显示”

win2009

论坛的帖子，值得借鉴

1. 
   
2. Option Explicit
   
3. '鼠标经过高亮显示
   
4. Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
   
5. Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
   
6. Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
   
7. Type POINTAPI
   
8.     x As Long
   
9.     y As Long
   
10. End Type
    
11. Dim m_blnTimerOn As Boolean
    
12. Dim m_lngTimerId As Long
    
13. Dim m_NewRange As Range
    
14. Dim m_OldRange As Range
    
15. Sub StartTimer()
    
16.     If Not m_blnTimerOn Then
    
17.         m_lngTimerId = SetTimer(0, 0, 0.05, AddressOf TimerProc)
    
18.         m_blnTimerOn = True
    
19.         ' Set m_OldRange = ActiveSheet.Range("A1")
    
20.     End If
    
21. End Sub
    
22. Public Function TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    
23.     Dim lngCurPos As POINTAPI
    
24.     '
    
25.     On Error Resume Next
    
26.     GetCursorPos lngCurPos
    
27.     Set m_NewRange = ActiveWindow.RangeFromPoint(lngCurPos.x, lngCurPos.y)
    
28.     With m_NewRange
    
29.         If m_OldRange.Address <> .Address Then
    
30.             Dim r As Long, c As Long
    
31.             r = .Row
    
32.             c = .Column
    
33.             Rows(r).Select
    
34. '            Union(Columns(c), Rows(r)).Select '这句行列同时选定
    
35.         End If
    
36.     End With
    
37.     Set m_OldRange = m_NewRange
    
38.     TimerProc = 0
    
39. End Function
    
40. Sub StopTimer()
    
41.     If m_blnTimerOn Then
    
42.         KillTimer 0, m_lngTimerId
    
43.         m_blnTimerOn = False
    
44.     End If
    
45. End Sub
    
46. Public Sub 开始()
    
47.     StartTimer
    
48. End Sub
    
49. Public Sub 结束()
    
50.     StopTimer
    
51. End Sub
    

复制代码

屏幕固定功能以实现，替换下面两个代码，就行你试试

Public Sub 开始()
    ActiveSheet.ScrollArea = ActiveCell.Address
    StartTimer
End Sub
Public Sub 结束()
    ActiveSheet.ScrollArea = ""
    StopTimer
End Sub

wqfzqgk

像这样玩玩可以，要是真正用的话，占用内存太多，真的用处不大，升级到2013时一点用处没有啦，他自己有个小动画，会影响这种功能的使用

佛山小老鼠

真的很谢谢你提供，同时感谢写原代码的朋友，我把它加入完美工具箱了，不错，很好虽然有一点点缺点。我很喜欢

win2009

佛山小老鼠 发表于 2012-8-19 17:39
真的很谢谢你提供，同时感谢写原代码的朋友，我把它加入完美工具箱了，不错，很好

哈哈，你好快，这个真是太游泳了
若能把数据地图加入就更好了，论坛有这个你搜索一下

佛山小老鼠

win2009 发表于 2012-8-19 17:48
哈哈，你好快，这个真是太游泳了
若能把数据地图加入就更好了，论坛有这个你搜索一下

嗯，我看看

wpxxsyzx

个人觉得光标跟随，眼花缭乱的反而眼睛累

leolee82

还不如直接搞个类似auto CAD中的十字光标

win2009

leolee82 发表于 2012-8-20 11:05
还不如直接搞个类似auto CAD中的十字光标

我也是这么想，但是可能实现不了，坛子里没有人能做到

柳絮飘飘

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Me.Cells.Interior.ColorIndex = xlNone
Target.EntireRow.Interior.ColorIndex = 33
End Sub

shaowu459

佛山小老鼠 发表于 2012-8-19 17:39
真的很谢谢你提供，同时感谢写原代码的朋友，我把它加入完美工具箱了，不错，很好虽然有一点点缺点。我很喜 ...

这样的跟随是不是比较耗费系统资源？也就是代码时时刻刻监测鼠标的运动然后再后台运算？