P
PBezucha
To:
http://www.microsoft.com/communitie...&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
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
http://www.microsoft.com/communitie...&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
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