Marking points read for coordinates
 

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

Marking points read for coordinates
 

Peter,
Yes, if we want to use scrolling, the pixel counting looses any sense. It's
only a rough tool: I use it preferably for digging out the more exact values
out of some charts in printed publications. Have not tried to process data
taken from tablets, too.
Thank for your remarks, will you still elaborate the macro?
--
Petr Bezucha


"Peter T" wrote:

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

Marking points read for coordinates
 

will you still elaborate the macro?

OK, try these changes to your code as posted

In "Private Sub GetCoordinates()" comment (or delete) all the code between

' 'Marking the just read point
' If AddPointDeck Then
'''''' code
' End If

and replace with this code

''''''''''''''''''' replacement code
' Marking the just read point
Dim bSame As Boolean
If AddPointDeck Then
On Error Resume Next
bSame = grBase.Address = ActiveWindow.VisibleRange(1).Address
If bSame = False Or Err.Number Then
GetOffsetToPointZero gXoffset, gYoffset, False
End If
On Error GoTo CancelOnKey

XPos = 0.75 * XPos
YPos = 0.75 * YPos

XPos = XPos - gXoffset - TargetMarkerSize / 2
YPos = YPos - gYoffset - TargetMarkerSize / 2

PN = ActiveSheet.Shapes.AddShape(msoShapeOval, XPos, YPos, _
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
'==============================


Add a new module with the following

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hwnd1 As Long, ByVal hwnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function GetWindowRect Lib "user32" _
(ByVal HWND As Long, lpRect As RECT) As Long

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public grBase As Range
Public gXoffset As Double
Public gYoffset As Double

Sub GetOffsetToPointZero(xPointOS As Double, yPointOS As Double, _
Optional bDelCht As Boolean = False)
' The GetCursorPos API returns pixel coordinates relative to topleft corner
of the
' monitor. But we need an offset to the topleft Visible Cell, and from that
to
' cell A1 which is the base for all object coordinates on a sheet.
' One way to get that is by making use of an embedded chart
' which has in its own window (while active).
' Place a dummy chart in the top left of the Visible range,
' get its window handle and with that get its window coordinates
' (best not to use this with any other embedded charts on the sheet)
'
Dim chtObj As ChartObject
Dim hwnd1&, hwnd2&, hwnd3&
Dim rct As RECT

Dim PP As Single ' pixels per point
PP = 0.75 ' typically 0.75 but should confirm with API's

Dim sDummyChart As String
sDummyChart = "DummyChart"

On Error Resume Next
Set chtObj = ActiveSheet.ChartObjects(1)
On Error GoTo 0

Set grBase = ActiveWindow.VisibleRange(1)

With grBase
' -ve offset to VisibleRange in points
xPointOS = -.Left
yPointOS = -.Top

If chtObj Is Nothing Then
Set chtObj = ActiveSheet.ChartObjects.Add( _
.Left, .Top, .Width, .Height)
chtObj.Name = sDummyChart
Else
' previously created dummy-chart exists
chtObj.Left = .Left
chtObj.Top = .Top
End If
End With

chtObj.Visible = True
chtObj.Activate

'EXCELE is the classname of an embedded charts window
' its Grandparent's window is XLMAIN
hwnd1 = FindWindow("XLMAIN", Application.Caption)
hwnd2 = FindWindowEx(hwnd1, 0&, "XLDESK", vbNullString)
hwnd3 = FindWindowEx(hwnd2, 0&, "EXCELE", vbNullString)

If bDelCht Then
chtObj.Delete
Else
' keep the dummy chart invisible for future use
chtObj.Visible = False
grBase.Activate
End If

Call GetWindowRect(hwnd3, rct)

With rct
' screen pixel coord's of the top left visible cell
' converted to points, added to visible range offset
xPointOS = xPointOS + (.Left * PP)
yPointOS = yPointOS + (.Top * PP)
Debug.Print .Left * PP, .Right * PP
End With

End Sub

Should be able to scroll anywhere on the sheet and place your picture with
the shortcut OnKey.

If Excel's window is resized or moved, or any toolbars above the sheet
changed, will need to "reset". Simply scroll (one cell is enough) and run
the OnKey macro again

Regards,
Peter T

"PBezucha" wrote in message
...
Peter,
Yes, if we want to use scrolling, the pixel counting looses any sense.
It's
only a rough tool: I use it preferably for digging out the more exact
values
out of some charts in printed publications. Have not tried to process data
taken from tablets, too.
Thank for your remarks, will you still elaborate the macro?
--
Petr Bezucha


"Peter T" wrote:

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

Marking points read for coordinates
 

Forgot to mention I don't think the chart-window helper method to relate
pixels to sheet coordinates will work in Excel 2007.

Peter T

Marking points read for coordinates
 

Hi Peter,

Thank you for the dream cooperation. I will work on the proposed changes
over the weekend so as to create the best of us, and tell back.
Its pity that the Excel users out of economical rank have relatively scarce
web contact. I think the miracles for the lower and middle level users from
technical branches can be accomplished, provided somebody helps people to get
over some obstacles that seem at the first sight to eliminate Excel in favor
of incommensurate and expensive other applications.

Regards,
--
Petr Bezucha


"Peter T" wrote:

will you still elaborate the macro?

OK, try these changes to your code as posted

In "Private Sub GetCoordinates()" comment (or delete) all the code between

' 'Marking the just read point
' If AddPointDeck Then
'''''' code
' End If

and replace with this code

''''''''''''''''''' replacement code
' Marking the just read point
Dim bSame As Boolean
If AddPointDeck Then
On Error Resume Next
bSame = grBase.Address = ActiveWindow.VisibleRange(1).Address
If bSame = False Or Err.Number Then
GetOffsetToPointZero gXoffset, gYoffset, False
End If
On Error GoTo CancelOnKey

XPos = 0.75 * XPos
YPos = 0.75 * YPos

XPos = XPos - gXoffset - TargetMarkerSize / 2
YPos = YPos - gYoffset - TargetMarkerSize / 2

PN = ActiveSheet.Shapes.AddShape(msoShapeOval, XPos, YPos, _
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
'==============================


Add a new module with the following

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hwnd1 As Long, ByVal hwnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function GetWindowRect Lib "user32" _
(ByVal HWND As Long, lpRect As RECT) As Long

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public grBase As Range
Public gXoffset As Double
Public gYoffset As Double

Sub GetOffsetToPointZero(xPointOS As Double, yPointOS As Double, _
Optional bDelCht As Boolean = False)
' The GetCursorPos API returns pixel coordinates relative to topleft corner
of the
' monitor. But we need an offset to the topleft Visible Cell, and from that
to
' cell A1 which is the base for all object coordinates on a sheet.
' One way to get that is by making use of an embedded chart
' which has in its own window (while active).
' Place a dummy chart in the top left of the Visible range,
' get its window handle and with that get its window coordinates
' (best not to use this with any other embedded charts on the sheet)
'
Dim chtObj As ChartObject
Dim hwnd1&, hwnd2&, hwnd3&
Dim rct As RECT

Dim PP As Single ' pixels per point
PP = 0.75 ' typically 0.75 but should confirm with API's

Dim sDummyChart As String
sDummyChart = "DummyChart"

On Error Resume Next
Set chtObj = ActiveSheet.ChartObjects(1)
On Error GoTo 0

Set grBase = ActiveWindow.VisibleRange(1)

With grBase
' -ve offset to VisibleRange in points
xPointOS = -.Left
yPointOS = -.Top

If chtObj Is Nothing Then
Set chtObj = ActiveSheet.ChartObjects.Add( _
.Left, .Top, .Width, .Height)
chtObj.Name = sDummyChart
Else
' previously created dummy-chart exists
chtObj.Left = .Left
chtObj.Top = .Top
End If
End With

chtObj.Visible = True
chtObj.Activate

'EXCELE is the classname of an embedded charts window
' its Grandparent's window is XLMAIN
hwnd1 = FindWindow("XLMAIN", Application.Caption)
hwnd2 = FindWindowEx(hwnd1, 0&, "XLDESK", vbNullString)
hwnd3 = FindWindowEx(hwnd2, 0&, "EXCELE", vbNullString)

If bDelCht Then
chtObj.Delete
Else
' keep the dummy chart invisible for future use
chtObj.Visible = False
grBase.Activate
End If

Call GetWindowRect(hwnd3, rct)

With rct
' screen pixel coord's of the top left visible cell
' converted to points, added to visible range offset
xPointOS = xPointOS + (.Left * PP)
yPointOS = yPointOS + (.Top * PP)
Debug.Print .Left * PP, .Right * PP
End With

End Sub

Should be able to scroll anywhere on the sheet and place your picture with
the shortcut OnKey.

If Excel's window is resized or moved, or any toolbars above the sheet
changed, will need to "reset". Simply scroll (one cell is enough) and run
the OnKey macro again

Regards,
Peter T

"PBezucha" wrote in message
...
Peter,
Yes, if we want to use scrolling, the pixel counting looses any sense.
It's
only a rough tool: I use it preferably for digging out the more exact
values
out of some charts in printed publications. Have not tried to process data
taken from tablets, too.
Thank for your remarks, will you still elaborate the macro?
--
Petr Bezucha


"Peter T" wrote:

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

Marking points read for coordinates
 

Hi Petr,

Not sure I followed all that but it sounds good !

Regards,
Peter T

"PBezucha" wrote in message
...
Hi Peter,

Thank you for the dream cooperation. I will work on the proposed changes
over the weekend so as to create the best of us, and tell back.
It's pity that the Excel users out of economical rank have relatively
scarce
web contact. I think the miracles for the lower and middle level users
from
technical branches can be accomplished, provided somebody helps people to
get
over some obstacles that seem at the first sight to eliminate Excel in
favor
of incommensurate and expensive other applications.

Regards,
--
Petr Bezucha

<snip

Marking points read for coordinates
 

Petr, try this -

Private Sub GetCoordinates()
'Action sub deployed by clicking the ActionKey.
Dim P As Range, PN As String, XPos As Long, YPos As Long
Dim shp As Shape

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

With ActiveWindow
XPos = (XPos - .PointsToScreenPixelsX(0)) * 100 / .Zoom
YPos = (YPos - .PointsToScreenPixelsY(0)) * 100 / .Zoom
' this might not accurately correct zoom
End With

' include "add comment" code here if required from original

' If AddPointDeck Then

XPos = 0.75 * XPos
YPos = 0.75 * YPos

XPos = XPos - TargetMarkerSize / 2
YPos = YPos - TargetMarkerSize / 2

Set shp = ActiveSheet.Shapes.AddShape(msoShapeOval, XPos, YPos, _
TargetMarkerSize, TargetMarkerSize)
With shp
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = TargetMarkerColor
.Fill.Transparency = 0.5
.Line.Visible = msoFalse
.LockAspectRatio = msoTrue
End With
' End If
'==============================
R = R + 1
Exit Sub
CancelOnKey:
xyReadingFinish
End Sub

Regards,
Peter T



"PBezucha" wrote in message
...
Hi Peter,

Thank you for the dream cooperation. I will work on the proposed changes
over the weekend so as to create the best of us, and tell back.
It's pity that the Excel users out of economical rank have relatively
scarce
web contact. I think the miracles for the lower and middle level users
from
technical branches can be accomplished, provided somebody helps people to
get
over some obstacles that seem at the first sight to eliminate Excel in
favor
of incommensurate and expensive other applications.

Regards,
--
Petr Bezucha

Marking points read for coordinates
 

On Aug 23, 4:42*pm, "Peter T" <peter_t@discussions wrote:
Petr, try this -

Private Sub GetCoordinates()
'Action sub deployed by clicking the ActionKey.
Dim P As Range, PN As String, XPos As Long, YPos As Long
Dim shp As Shape

* * 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

* * With ActiveWindow
* * * * XPos = (XPos - .PointsToScreenPixelsX(0)) * 100 / .Zoom
* * * * YPos = (YPos - .PointsToScreenPixelsY(0)) * 100 / .Zoom
* * * * ' this might not accurately correct zoom
* * End With

' include "add comment" code here if required from original

* *' If AddPointDeck Then

* * * * XPos = 0.75 * XPos
* * * * YPos = 0.75 * YPos

* * * * XPos = XPos - TargetMarkerSize / 2
* * * * YPos = YPos - TargetMarkerSize / 2

* * * * Set shp = ActiveSheet.Shapes.AddShape(msoShapeOval, XPos, YPos, _
* * * * * * * * * * * * * * * * * * * * *TargetMarkerSize, TargetMarkerSize)
* * * * With shp
* * * * * * .Fill.Visible = msoTrue
* * * * * * .Fill.Solid
* * * * * * .Fill.ForeColor.SchemeColor = TargetMarkerColor
* * * * * * .Fill.Transparency = 0.5
* * * * * * .Line.Visible = msoFalse
* * * * * * .LockAspectRatio = msoTrue
* * * * End With
* *' End If
* * '==============================
* * R = R + 1
* * Exit Sub
CancelOnKey:
* * xyReadingFinish
End Sub

Regards,
Peter T

"PBezucha" wrote in message

...



Hi Peter,

Thank you for the dream cooperation. I will work on the proposed changes
over the weekend so as to create the best of us, and tell back.
It's pity that the Excel users out of economical rank have relatively
scarce
web contact. I think the miracles for the lower and middle level users
from
technical branches can be accomplished, provided somebody helps people to
get
over some obstacles that seem at the first sight to eliminate Excel in
favor
of incommensurate and expensive other applications.

Regards,
--
Petr Bezucha- Hide quoted text -

- Show quoted text -

Hi Petr and Peter,
I am following the discussion with interest - though I don't quite
understand the code fully.
Yes, I do work with large drawings and need to scroll down as well as
to the right.
Regards,
Pierre

Marking points read for coordinates
 

Peter,
It's pleasure to work with you. The previous version appeared flowless.
As I take it, the new one is corrected to avoid API calls that may have
vanished in xl2007 (I haven't it also to prove)? I'll try the change.
Regards

--
Petr Bezucha


"Peter T" wrote:

Petr, try this -

Private Sub GetCoordinates()
'Action sub deployed by clicking the ActionKey.
Dim P As Range, PN As String, XPos As Long, YPos As Long
Dim shp As Shape

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

With ActiveWindow
XPos = (XPos - .PointsToScreenPixelsX(0)) * 100 / .Zoom
YPos = (YPos - .PointsToScreenPixelsY(0)) * 100 / .Zoom
' this might not accurately correct zoom
End With

' include "add comment" code here if required from original

' If AddPointDeck Then

XPos = 0.75 * XPos
YPos = 0.75 * YPos

XPos = XPos - TargetMarkerSize / 2
YPos = YPos - TargetMarkerSize / 2

Set shp = ActiveSheet.Shapes.AddShape(msoShapeOval, XPos, YPos, _
TargetMarkerSize, TargetMarkerSize)
With shp
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = TargetMarkerColor
.Fill.Transparency = 0.5
.Line.Visible = msoFalse
.LockAspectRatio = msoTrue
End With
' End If
'==============================
R = R + 1
Exit Sub
CancelOnKey:
xyReadingFinish
End Sub

Regards,
Peter T



"PBezucha" wrote in message
...
Hi Peter,

Thank you for the dream cooperation. I will work on the proposed changes
over the weekend so as to create the best of us, and tell back.
It's pity that the Excel users out of economical rank have relatively
scarce
web contact. I think the miracles for the lower and middle level users
from
technical branches can be accomplished, provided somebody helps people to
get
over some obstacles that seem at the first sight to eliminate Excel in
favor
of incommensurate and expensive other applications.

Regards,
--
Petr Bezucha