Thanks for posting this. I hadn't realised that 'freeze panes' would
work like this. My app at the moment is for XL07 so it doesn't cause
a problem.

All the best,
Andrew


On 10 Feb, 16:11, "Peter T" <peter_t@discussions wrote:
Put the following into ThisWorkbook and Normal modules as indicated.
Hold Ctrl and Right-click to center "TheSun" under the cursor

''' ThisWorkbook module

Option Explicit
Private Declare Function GetKeyState32 Lib "user32" _
* * Alias "GetKeyState" (ByVal vKey As Integer) As Integer

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, _
* * * * * * * * * * * * * * ByVal Target As Range, Cancel As Boolean)
Dim bCtrl As Long

' Right-click and hold Ctrl <<<

* * ' is Ctrl pressed
* * bCtrl = GetKeyState32(vbKeyControl) < 0

* * If bCtrl Then
* * * * Cancel = True ' prevent the rt-click menu
* * * * TestCursorToPoints Sh
* * End If

End Sub

''' end ThisWorkbook module

''' code in normal module

Option Explicit
''' pmbthornton at gmail dot com

' re points per pixel
Private Const LOGPIXELSX As Long = 88&
Private Const POINTS_PER_INCH As Long = 72&
Private Declare Function GetDC Lib "user32" ( _
* * * * * * * * * * ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
* * * * * * * * * * ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
* * * * * * * * * * ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

' re cursor position
Private Type POINTAPI
* * X As Long
* * Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32.dll" ( _
* * * * * * * * * * ByRef lpPoint As POINTAPI) As Long

Private mPPP As Single * *' points per pixel

Function CursorToPoints(X As Single, Y As Single) As Long
Dim x0 As Single, y0 As Single
Dim zm As Single
Dim rngCursor As Range
Dim pta As POINTAPI

* * On Error GoTo errH

* * If mPPP = 0 Then getPPP

* * Call GetCursorPos(pta)

* * With ActiveWindow

* * * * If .Panes.Count = 1 Then
* * * * * * x0 = .PointsToScreenPixelsX(0)
* * * * * * y0 = .PointsToScreenPixelsY(0)

* * * * ElseIf Val(Application.Version) = 12 Then

* * * * * * With .Panes(.Panes.Count)
* * * * * * * * x0 = .PointsToScreenPixelsX(0)
* * * * * * * * y0 = .PointsToScreenPixelsY(0)
* * * * * * End With
* * * * Else
* * * * * * Err.Raise 10100, , _
* * * * * * * * "To do: cater for Freeze Panes in 2000-2003"
* * * * End If

* * * * If x0 = 0 And y0 = 0 Then
* * * * * * Err.Raise 10200, , _
* * * * * * * * "At least part of the worksheet must be in view"
* * * * End If

* * * * zm = 100 / .Zoom

* * * * X = (pta.X - x0) * mPPP * zm
* * * * Y = (pta.Y - y0) * mPPP * zm

* * * * On Error Resume Next
* * * * ' attempt to return the cell under the cursor
* * * * ' btw, if only need to return the cell under the mouse
* * * * ' this is all that's required
* * * * Set rngCursor = .RangeFromPoint(pta.X, pta.Y)
* * * * On Error GoTo errH

* * End With

* * If Not rngCursor Is Nothing Then

* * * * If rngCursor.Address = ActiveCell.Address Then
* * * * * * CursorToPoints = 2 ' mouse over activecell
* * * * Else
* * * * * * CursorToPoints = 1 ' mouse not over activecell
* * * * End If

* * ElseIf X < 0 Or Y < 0 Then
* * * * CursorToPoints = 0 * * ' mouse above or to left of visible cells
* * Else
* * * * CursorToPoints = -1 * *' mouse to right or below visible cells
* * End If

* * Exit Function

errH:
* * MsgBox Err.Description, , "CursorToPoints"

End Function

Sub getPPP()
' get Points / Pixel
' typically ppp is 72/96 = 0.75 in systems with Normal Fonts
Dim hWin As Long
Dim dcDT As Long
Dim nDPI As Long

* * hWin = GetDesktopWindow
* * dcDT = GetDC(hWin)
* * nDPI = GetDeviceCaps(dcDT, LOGPIXELSX)
* * ReleaseDC hWin, dcDT
* * mPPP = POINTS_PER_INCH / nDPI

End Sub

''''''' Test code '''''''

Sub test()
* * TestCursorToPoints ActiveSheet
End Sub

Sub TestCursorToPoints(ws As Worksheet)
Dim bVis As Boolean, bCenter As Boolean
Dim res As Long
Dim X As Single, Y As Single

* * res = CursorToPoints(X, Y)

* * bVis = CBool(res)
* * bCenter = True

* * MoveTheSun ws, X, Y, bVis, bCenter

End Sub

Sub MoveTheSun(ws As Worksheet, X As Single, Y As Single, _
* * * * * * * * * * * * * *bVis As Boolean, bCenter As Boolean)
Dim nL As Single, nT As Single
Dim shp As Shape
Const cW As Single = 24, cH As Single = 24
Const cSUN As String = "TheSun"

* * nL = X
* * nT = Y
* * If bCenter Then
* * * * nL = nL - (cW / 2)
* * * * nT = nT - (cH / 2)
* * End If

* * On Error Resume Next
* * Set shp = ActiveSheet.Shapes(cSUN)
* * On Error GoTo 0

* * If shp Is Nothing Then
* * * * Set shp = ws.Shapes.AddShape(msoShapeSun, nL, nT, cW, cH)
* * * * shp.Fill.ForeColor.RGB = RGB(255, 240, 140)
* * * * shp.Line.ForeColor.RGB = RGB(255, 180, 0)
* * * * shp.Name = cSUN

* * Else
* * * * With shp
* * * * * * .Left = nL
* * * * * * .Top = nT
* * * * * * .Width = cW
* * * * * * .Height = cH
* * * * * * .Visible = bVis
* * * * End With
* * End If

End Sub

Regrds,
Peter T