Hallo Andreas,
der bisherige Code hatte noch einen Gedankenfehler. Er berücksichtigte nur die aktivierte Zelle.
Nachfolgend mal ein Code, der jetzt wirklich beim Überfahren einer der gewünschten Zellen, den Mauscursor ändert. Bitte sicherstellen, dass der Timer beim Verlassen des Tabellenblattes und beim Schließen der Mappe abgeschaltet wird. Inwieweit die Funktionalität jetzt in jeder Lebenslage sicher ist, kann ich nicht sagen.
Option Explicit
Public Declare PtrSafe Function GetCursorPos Lib "user32" ( _
lpPoint As POINTAPI) As Long
Public Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public iTimerID As LongPtr
Public hWnd As LongPtr
Sub CheckMouseOverRange()
Dim R As RECT, Pt As POINTAPI, AC As Object
Dim iCur As Integer, i As Integer, sBer() As String
sBer = Split("A1,C3,D5", ",")
If iTimerID <> 0 Then KillTimer 0, iTimerID: iTimerID = 0
iCur = xlDefault
For i = 0 To UBound(sBer)
Set AC = Range(sBer(i))
With ActiveWindow.ActivePane
On Error Resume Next
R.Left = .PointsToScreenPixelsX(AC.Left)
R.Top = .PointsToScreenPixelsY(AC.Top)
R.Right = .PointsToScreenPixelsX(AC.Offset(0, 1).Left)
R.Bottom = .PointsToScreenPixelsY(AC.Offset(1, 0).Top)
End With
GetCursorPos Pt
If Pt.x > R.Left And Pt.y > R.Top And Pt.x < R.Right And Pt.y < R.Bottom Then
iCur = xlNorthwestArrow: Exit For
End If
DoEvents
Next i
Application.Cursor = iCur
If iTimerID = 0 Then iTimerID = SetTimer(0, 0, 100, AddressOf CheckMouseOverRange)
End Sub
'Ins Modul der Tabelle
Private Sub Worksheet_Activate()
CheckMouseOverRange
End Sub
Private Sub Worksheet_Deactivate()
If iTimerID <> 0 Then KillTimer 0, iTimerID: iTimerID = 0
End Sub
'In diese Arbeitsmappe
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If iTimerID <> 0 Then KillTimer 0, iTimerID: iTimerID = 0
End Sub
Private Sub Workbook_Open()
If ActiveSheet.Name = "Tabelle1" Then CheckMouseOverRange
End Sub
viele Grüße
Karl-Heinz
|