Hi Petr,

The idea to invoking the code with OnKey is a good one. Just a couple of
comments.

The positioning relies on knowing the screen coordinates of the top left of
the sheet, ie offset from screen pixels position 0:0 to sheet points
position 0:0. I see you cater for that like this with constants, which I
assume are correct in your setup (but not in mine) -
XPos - 24, YPos - 101

Of course user can adjust 24 & 101 to their own setup with a maximized
window and A1 visible. However there are various approaches to calculate
screen coords of point 0:0 so it's not necessary to "guess", more work of
course!

The second thing to consider is if cell A1 is not visible all the
calculations will be completely wrong. Although it's possible to get the
offset from cell A1 to VisibleRange(1,1) that's still not quite enough, the
vertical header width increases as user scrolls down. Again the relative
positions and offsets can be recalculated with one of the approaches. From
the OP's other post (Pierre) I understand he is handling large images may
need to be scrolled.

Regards,
Peter T


"PBezucha" wrote in message
...
To:
http://www.microsoft.com/communities...d-5c6d7e9e5cb1

Pierre,

As I promised, I will show you my way, though it is obviously late for
your
purpose. I am using normally the basic version, without marking points,
and
thus without the inserted ==== parts of the following macro. Its advantage
is
that you need not do any exercises with your picture, because, as you
know,
first drawing any markers requires conversion between points and pixels.
Though I had intended to try the marking for times, I finished the work
just
after having been provoked by you. It took me some sweat. Thanks.

The advantage to the otherwise perfect Peter's method is that mine is
programmatically simpler, as it doesn't use class modules. For marking,
however, you need also transfer your picture into the empty chart. The
subtractive constants: 24 and 101 correct the marker position, and depend
on
the left and upper picture position. So far I set them both by trial and
error because they are the same provided the picture is situated at the
corner.

A slight modification is the replacement of a Wingdings sign by a
semitransparent disc.

Option Explicit
Dim R As Long, C As Long, AddComment As Boolean, Comm As String, MB As
Long,
SN As String, _
AddPointDeck As Boolean, ActionKeyCode As String
Const Title As String = "Reading cursor coordinates", ActionKey As String
=
"`", _
TargetMarkerColor As Long = 15, TargetMarkerSize As Long = 8
'ActionKey can by chosen arbitrarily for comfortable hand position
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI)
As
Long
Dim Pos As POINTAPI

Sub xyReadingStart()
'The Sub prepares the reading of cursor positions.
'Before calling, the upper left cell of the range must be selected in a
worksheet,
'where the x- and y-coordinates will be written down into two adjacent
columns.
'If this cell is incidentally not empty, the Sub asks for permitting to
overwrite.
'The next question is whether the comment, pertained to each point, should
be recorded
'in the left column; if the answer is positive, then the x- and y- columns
will be
'shifted by one to the right. Then, after each reading off, you are asked
for a new
'comment, if OK, the comment is simply repeated. The meaning of comments
is
clear
'when reading several series of points etc.
'The last inquiry is whether the recorded points should be marked by a
target cover.
'It is a colored, half-transparent circle that covers the cursor position
to
remind
'that the point has been once treated.
'Finally, the Sub modifies the action of ActionKey and 'ESCAPE' keys. The
first starts
'each reading of cursor position by Sub GetCoordinates, the other finishes
the reading
'cycle and returns these keys the previous meaning by Sub xyReadingFinish.
ActionKeyCode = "{" & ActionKey & "}"
R = ActiveCell.Row
C = ActiveCell.Column
If Not IsEmpty(ActiveCell) Then
MB = MsgBox("Overwrite the cell content?", _
vbOKCancel + vbDefaultButton2 + vbQuestion, Title)
If MB = vbCancel Then Exit Sub
End If

MB = MsgBox("Comments in this column", _
vbYesNo + vbQuestion + vbDefaultButton2, Title)
AddComment = MB = vbYes
'=============================
MB = MsgBox("Marking points", vbYesNo + vbQuestion + vbDefaultButton1,
Title)
AddPointDeck = MB = vbYes
'=============================
SN = ActiveSheet.Name
Application.OnKey ActionKeyCode, "GetCoordinates"
Application.OnKey "{ESC}", "xyReadingFinish"
End Sub

Private Sub GetCoordinates()
'Action sub deployed by clicking the ActionKey.
Dim P As Range, PN As String, XPos As Long, YPos As Long
GetCursorPos Pos
On Error GoTo CancelOnKey
'Target cell
Set P = Worksheets(SN).Cells(R, C)
If Not IsEmpty(P) Then
Exit Sub
End If
'Record
XPos = Pos.X
YPos = Pos.Y
P.Offset(0, -AddComment).Value = XPos
P.Offset(0, 1 - AddComment).Value = YPos
If AddComment Then
Comm = Application.InputBox("Comment to this point", Title, Comm)
If Comm < ActionKey Then P.Value = Comm
End If
'=============================
'Marking the just read point
If AddPointDeck Then
XPos = 0.75 * XPos
YPos = 0.75 * YPos
PN = ActiveSheet.Shapes.AddShape(msoShapeOval, XPos - 24, YPos - 101, _
TargetMarkerSize, TargetMarkerSize).Name
With ActiveSheet.Shapes(PN).DrawingObject.ShapeRange
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = TargetMarkerColor
.Fill.Transparency = 0.6
.Line.Visible = msoFalse
.LockAspectRatio = msoTrue
End With
End If
'==============================
R = R + 1
Exit Sub
CancelOnKey:
xyReadingFinish
End Sub

Private Sub xyReadingFinish()
'Sub cancels the temporary effect of shortkeys 'ESCAPE' and ActionKey
With Application
.OnKey "{ESC}"
.OnKey ActionKeyCode
End With
'and returns into the worksheet with recorded readings
Worksheets(SN).Activate
End Sub

Regards

--
Petr Bezucha