香港新浪網 MySinaBlog
« 上一篇 | 下一篇 »
Emily | 1st Oct 2006, 19:30 PM | API / Add-in | (2555 Reads)

Change Color when Mouse On Cell

A nice API code from Ivan F Moala but it will affect Excel performance

Option Explicit
'//
'// Cursor pos orig by rafaaj2000

'// Addressof routines found here;
'// http://www.xcelfiles.com/API_09.html
'// http://www.xcelfiles.com/VBA_Clock.html

'// Timer routines;
'// http://www.xcelfiles.com/API_02.html
'//


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
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)

If m_NewRange.Address <> m_OldRange.Address Then
    With
Range("A1")
        .Font.ColorIndex = 0
        .Font.Italic = False
    End With
End If


If m_NewRange.Address = "$A$1" Then
    With
Range("A1")
        .Font.ColorIndex = 3
        .Font.Italic = True
    End With
End If

    
'//
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


'

Original Post in MrExcel:

http://www.mrexcel.com/board2/viewtopic.php?t=235676&postdays=0&postorder=asc&&start=10