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
