Re: Marking points read for coordinates

Tech Tip: Click here to run a free scan for Windows Errors and optimize PC performance

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


"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 = Active***.Shapes.AddShape(msoShapeOval, XPos, YPos, _
TargetMarkerSize,
TargetMarkerSize).Name

With Active***.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 ***.
' 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 ***)
'
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 = Active***.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 = Active***.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 *** and place your picture with
the shortcut OnKey.

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

Regards,
Peter T

"PBezucha" <PBezucha@xxxxxxxxxxxxxxxxxxxxxxxxx> wrote in message
news:8547CDE6-5945-4228-AB34-33C19FCB67B7@xxxxxxxxxxxxxxxx
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 ***, ie offset from screen pixels position 0:0 to *** 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" <PBezucha@xxxxxxxxxxxxxxxxxxxxxxxxx> wrote in message
news:AE85A1E7-D056-4930-AC83-4BE4EBB35D40@xxxxxxxxxxxxxxxx
To:
http://www.microsoft.com/communities/newsgroups/en-us/default.aspx?&query=Wingdings&lang=en&cr=US&guid=&sloc=en-us&dg=microsoft.public.excel.programming&p=1&tid=8a27634a-5743-496f-9c7d-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
work***,
'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
.

Quantcast