Greg Wilson - XY coordinates of a worksheet

[dave.cuthill]

Greg Wilson ....

You mentioned a function to determine the X-Y coordinates of a
worksheet in the following post. The link does not work any longer -
do you still have the example available?

_______________________________
"The code below will return the x- and y-coordinates in pixels as
opposed to
points. Note that it is also window based instead of worksheet based.
Doing
something with it is the challenge:

Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As
Long
Type POINTAPI
x As Long
y As Long
End Type


Sub xxx()
Dim pos As POINTAPI
GetCursorPos pos
MsgBox pos.x & vbCr & pos.y
End Sub


I have recently posted code that determines the position of the top-
left
corner of the worksheet in pixels and also converts pixels to points
and
compensates (albeit not perfectly) for zoom. You need to know the
position of
the top-left corner of the worksheet in pixels so that you can
subtract the
correct offsets if you are to convert to points. You can thus direct
the
cursor to a specified point within the worksheet. If you're
interested:


http://tinyurl.com/l7uog "

 

[Greg Wilson]

Explanation of the appended demo macros:

1. The SetUp macro remaps the "z" key so that when you type "z" it will
instead run the TestMoveShapeToMouse macro. It also sets the cursor to the
northwest arrow. Since the demo code shows how a shape can be moved to the
position of the mouse pointer, if you had to click a button to activate the
macro, the shape would always go to the button since that's where the mouse
pointer must go (to click it).

2. The UndoSetUp macro resets the "z" key to normal. Will also reset on
closing the workbook. It also resets the cursor to Excel's default.

3. The TestMoveShapeToMouse macro is where you decide the identity of the
shape you want to move to the position of the mouse pointer. Change
ActiveSheet.Shapes(1) to whatever you prefer.

4. The main routine is the MoveShapeToMouse macro. It is passed the
identity of the shape you want to move. It then will make it jump to the
mouse pointer.

Note that the zoom correction function needs work. I think I should have
used simple pixel offsets instead of correction factors. Perhaps another day.
You may wish to improve this yourself.

Paste the following code to a standard module and run the Setup macro. Put a
shape object on the worksheet. Then press the "z" key.

Also try holding down the "z" key and moving the mouse. You can see how this
could be used as a new way to drag shapes. You could use RangeFromPoint to
identify a shape and then drag it this way for instance :-

Option Explicit
Private Declare Function GetDC _
Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDeviceCaps _
Lib "Gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC _
Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Declare Function GetCursorPos _
Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Declare Function GetKeyState _
Lib "user32" (ByVal nVirtKey As Long) As Integer
Declare Function timeGetTime Lib "winmm.dll" () As Long

Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Public Type POINTAPI
x As Long
y As Long
End Type

Sub SetUp()
With Application
.OnKey "z", "TestMoveShapeToMouse"
.Cursor = xlNorthwestArrow
End With
End Sub

Sub UndoSetUp()
With Application
.OnKey "z"
.Cursor = xlDefault
End With
End Sub

Sub TestMoveShapeToMouse()
'Change shape to suit
MoveShapeToMouse ActiveSheet.Shapes(1)
End Sub

Sub MoveShapeToMouse(shp As Shape)
Dim cp As POINTAPI
Dim xpos_0 As Double, ypos_0 As Double
Dim z As Double

On Error Resume Next
GetCursorPos cp
With ActiveWindow
z = CorrectZoomFactor(.Zoom)
xpos_0 = .PointsToScreenPixelsX(0)
ypos_0 = .PointsToScreenPixelsY(0)
End With
Application.Cursor = xlNorthwestArrow
shp.Left = (cp.x - xpos_0) / z * PPPixelX
shp.Top = (cp.y - ypos_0) / z * PPPixelY
'Application.Cursor = xlDefault
On Error GoTo 0
End Sub

Function PPPixelX() As Double
Dim hDC As Long
hDC = GetDC(0)
PPPixelX = 72 / GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC 0, hDC
End Function

Function PPPixelY() As Double
Dim hDC As Long
hDC = GetDC(0)
PPPixelY = 72 / GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC 0, hDC
End Function

'Following zoom correction function needs work...
Function CorrectZoomFactor(ByVal z As Single) As Single
Select Case z
Case 200
z = 2
Case 175
z = 1.765
Case 150
z = 1.529
Case 125
z = 1.235
Case 100
z = 1
Case 90
z = 0.882
Case 85
z = 0.825
Case 80
z = 0.82
Case 75
z = 0.74
Case 70
z = 0.705
Case 65
z = 0.645
Case 60
z = 0.588
Case 55
z = 0.53
Case 50
z = 0.5296
Case Else
z = 1.0069 * z + 0.0055
End Select
CorrectZoomFactor = z
End Function

 

[Greg Wilson]

Sorry, the CorrectZoomFactor function was half-baked and you need to make
another minor change. In the MoveShapeToMouse macro, change:

z = CorrectZoomFactor(.Zoom)

to:

z = CorrectZoomFactor(.Zoom / 100)

Also, substitute the following for the CorrectZoomFactor function:

Function CorrectZoomFactor(ByVal z As Single) As Single
Select Case z
Case 2
z = 2
Case 1.75
z = 1.765
Case 1.5
z = 1.529
Case 1.25
z = 1.235
Case 1
z = 1
Case 0.9
z = 0.882
Case 0.85
z = 0.825
Case 0.8
z = 0.82
Case 0.75
z = 0.74
Case 0.7
z = 0.705
Case 0.65
z = 0.645
Case 0.6
z = 0.588
Case 0.55
z = 0.53
Case 0.5
z = 0.5296
Case Else
z = 1.0069 * z + 0.0055
End Select
CorrectZoomFactor = z
End Function

Greg

 

[dave.cuthill]

Thanks this is very helpful - glad you were able to dig it up from
your archive.