Place wingding on specific coordinates - possible?

[Pierre]

Hi all,
I measure distances, areas, etc. on a drawing inserted on a Sheet
using the coordinates when the mouse was clikced. However, If I click
on coordinate, say (450,370) I would like a wingding to be placed on
that coordinate as a reminder that I've already clicked on that spot
on the drawing. Is it possible? I don't now here to start probramming
this. Thanks in advance

 

[Pierre]

Hi all,
I measure distances, areas, etc. on a drawing inserted on a Sheet
using the coordinates when the mouse was clikced. However, If I click
on coordinate, say (450,370) I would like a wingding to be placed on
that coordinate as a reminder that I've already clicked on that spot
on the drawing. Is it possible? I don't now here to start probramming
this. Thanks in advance

Here is my feeble attempt to place wingding on "Picture1": Obviously
it does not work since I do not have the sytax to place the wingding
at certain coordinates (pPosition.X and pPosition.Y) instead of a
certain cell on the Sheet.

Directives would be greatly appreciated


Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long

Type POINTAPI
X As Long
Y As Long
End Type

Sub TEST1()
Application.ScreenUpdating = False
Dim pPosition As POINTAPI

Dim lReturn As Long
Dim ROW As Integer

Application.Cursor = xlNorthwestArrow

Range("T5").Select
lReturn = GetCursorPos(pPosition)


'PLACE THE VALUE OF X IN CELL T5
ActiveCell.Value = pPosition.X

'PLACE THE VALUE OF Y IN CELL U5
ActiveCell.Offset(0, 1).Value = pPosition.Y

'PLACE THE VALUES OF X AND Y IN COLUMNS AD AND AE FOR
'FURTHER MANIPULATION, I.E. DISTANCE BETWEEN CLICKS, ETC

ActiveCell.Offset(0, 10).Select

Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop

ROW = 4

ActiveCell.Value = pPosition.X
ActiveCell.Offset(0, 1).Select
Selection.Value = pPosition.Y

Application.ScreenUpdating = True


''PLACE WINGDING ON THE X AND Y POSITION

Debug.Print Application.Rept(Chr(116), 1)


End Sub

 

[Peter T]

In addition to your GetCursorPos (search this group) pixels to points
(search this group). Thereafter you need a way to determine when you've
pressed your mouse. Two approaches, the first is to subclass windows and
check windows events, trouble is that's a bit risky in VBA particularly if
you try debugging. Another way would be with a timer (search SetTimer,
AddressOf, KillTimer). The timer proc would call a routine to check the
button state of your mouse, looking first for a mouse down then a mouse up
(or vica versa), search "mouse_event" for examples and flags. I'll leave all
that to you but I thinks there's enough in the search terms to put it all
together.

A much simpler way perhaps would be to put your picture on a chart, or
format the chartarea with your picture (fill effects / picture).

Then, with the chart active, you can get a withevents chart class running
and trap one of the mouse events. That'll give you your XY "point" co-ords
with which you can insert (or copy/paste) a picture of your WingDing (I take
it that's a picture of a wingding character) and position to center over the
XY. Perhaps track XY with mouse move and apply your image with a keyboard
event to avoid getting popups.

Regards,
Peter T

 

[Pierre]

In addition to your GetCursorPos (search this group) pixels to points
(search this group). Thereafter you need a way to determine when you've
pressed your mouse. Two approaches, the first is to subclass windows and
check windows events, trouble is that's a bit risky in VBA particularly if
you try debugging. Another way would be with a timer (search SetTimer,
AddressOf, KillTimer). The timer proc would call a routine to check the
button state of your mouse, looking first for a mouse down then a mouse up
(or vica versa), search "mouse_event" for examples and flags. I'll leave all
that to you but I thinks there's enough in the search terms to put it all
together.

A much simpler way perhaps would be to put your picture on a chart, or
format the chartarea with your picture (fill effects / picture).

Then, with the chart active, you can get a withevents chart class running
and trap one of the mouse events. That'll give you your XY "point" co-ords
with which you can insert (or copy/paste) a picture of your WingDing (I take
it that's a picture of a wingding character) and position to center over the
XY. Perhaps track XY with mouse move and apply your image with a keyboard
event to avoid getting popups.

Regards,
Peter T






- Show quoted text -

Thanks, for the the info. Peter. Now I know where to start
researching. The WingDing is a diamond shaped character. My "picture"
is normally a building plan in PDF ( sometimes JPG - if scanned) and
I wiil try and instert the PDF in a chart as you suggested but I'm not
sure if that's possible. Thanks very much for the interest anuway.
Pierre

 

[Peter T]

I wasn't concentrating when I gave those search terms, at best not enough
and at worst misleading. One thing I forgot to mention is you'd need to
relate your cursor co-ords to the zero point co-rod position on the sheet,
doable but more work.

I don't see any reason why you can't put your picture into a chart (don't
think you need all that PDF).
- Insert your picture onto a sheet
- create an empty chart and size a little larger than your picture
- cut your picture
- select the chart (ensure you get filled handles)
- paste the picture into the chart

Here's some code to get you started (normal module and class module as
indicated)
Assumes Sheet3 is empty but see GetWingDingPic() to change

Select your chart, and run SetChart()

With the chart selected press left button and Ctrl to paste a the wingding
picture (or Ctrl-Alt to delete them)

While the ref "mcChart" maintains scope you can deactivate and reactivate
the chart


'''' code in a normal module

Dim mcChart As clsChtEvents

Sub SetChart()
Dim cht As Chart
' if will either reference the activechart
' or the first embedded chart on the sheet

On Error Resume Next
Set cht = ActiveChart

If cht Is Nothing Then
Set cht = ActiveSheet.ChartObjects(1).Chart
End If

If Not cht Is Nothing Then
Set mcChart = New clsChtEvents
Set mcChart.cht = cht Else
MsgBox "no chart on sheet"
End If

End Sub

Sub MakeWingDingPic(Optional s As String = "J")
Dim cel As Range
Dim pic As Picture
Dim ws As Worksheet

' an unused or hidden sheet
Set ws = Worksheets("Sheet3") ' << CHANGE if necessary

On Error Resume Next
Set pic = ws.Pictures("picWingDing_" & s)
On Error GoTo 0
If pic Is Nothing Then
ws.Pictures.Delete
Set cel = ws.Range("D4")
With cel
.Columns(1).Clear
.Font.Name = "WingDings"
.Font.Color = vbRed
'.Font.Bold = True
.Font.Size = 16
.Value = s
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Columns(1).EntireColumn.AutoFit
.Interior.ColorIndex = xlNone
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With

ws.Pictures.Paste

Set pic = ws.Pictures(ws.Pictures.Count)
With cel.Offset(, 2)
pic.Left = .Left
pic.Top = .Top
End With

pic.Name = "picWingDing_" & s
End If

pic.CopyPicture Appearance:=xlScreen, Format:=xlPicture

End Sub

'''' end normal module

''''' code in a class named "clsChtEvents"

Public WithEvents cht As Excel.Chart
Private mbFlag As Boolean

' typically points per pixel is 72/96
' but should confirm with API
Const PP As Single = 0.75
Const mcPrefix As String = "picWD_"

Private Sub cht_MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal x
As Long, ByVal y As Long)
Dim pic As Picture
Const FF As Single = -3 ' a fudge factor, experiment !

If Button = 1 And Shift = 2 Then 'left button & Ctrl
MakeWingDingPic
cht.Pictures.Paste
Set pic = cht.Pictures(cht.Pictures.Count)
With pic
.Left = x * PP - .Width / 2 + FF
.Top = y * PP - .Height / 2 + FF
End With
NamePic pic
mbFlag = True
cht.ChartArea.Select ' try and deselect the picture
ElseIf Shift = 6 Then ' Alt-Ctrl ' delete the pic's
DelWDpics
End If

End Sub

Private Sub cht_MouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal x
As Long, ByVal y As Long)
If mbFlag Then
mbFlag = False
cht.ChartArea.Select
End If
End Sub

Sub NamePic(pic As Picture)
Dim p As Picture
Dim i As Long
On Error Resume Next
Do
i = i + 1
Set p = cht.Pictures(mcPrefix & i)
Loop Until Err.Number > 0
pic.Name = mcPrefix & i
End Sub

Sub DelWDpics()
Dim p As Picture
For Each p In cht.Pictures
If InStr(p.Name, mcPrefix) = 1 Then
p.Delete
End If
Next
End Sub

'''' end class clsChtEvents


Regards,
Peter T

 

[Pierre]

I wasn't concentrating when I gave those search terms, at best not enough
and at worst misleading. One thing I forgot to mention is you'd need to
relate your cursor co-ords to the zero point co-rod position on the sheet,
doable but more work.

I don't see any reason why you can't put your picture into a chart (don't
think you need all that PDF).
- Insert your picture onto a sheet
- create an empty chart and size a little larger than your picture
- cut your picture
- select the chart (ensure you get filled handles)
- paste the picture into the chart

Here's some code to get you started (normal module and class module as
indicated)
Assumes Sheet3 is empty but see GetWingDingPic() to change

Select your chart, and run SetChart()

With the chart selected press left button and Ctrl to paste a the wingding
picture (or Ctrl-Alt to delete them)

While the ref "mcChart" maintains scope you can deactivate and reactivate
the chart

'''' code in a normal module

Dim mcChart As clsChtEvents

Sub SetChart()
Dim cht As Chart
    ' if will either reference the activechart
    ' or the first embedded chart on the sheet

    On Error Resume Next
    Set cht = ActiveChart

    If cht Is Nothing Then
        Set cht = ActiveSheet.ChartObjects(1).Chart
    End If

    If Not cht Is Nothing Then
        Set mcChart = New clsChtEvents
        Set mcChart.cht = cht    Else
        MsgBox "no chart on sheet"
    End If

End Sub

Sub MakeWingDingPic(Optional s As String = "J")
Dim cel As Range
Dim pic As Picture
Dim ws As Worksheet

    ' an unused or hidden sheet
    Set ws = Worksheets("Sheet3") ' << CHANGE if necessary

    On Error Resume Next
    Set pic = ws.Pictures("picWingDing_" & s)
    On Error GoTo 0
    If pic Is Nothing Then
        ws.Pictures.Delete
        Set cel = ws.Range("D4")
        With cel
            .Columns(1).Clear
            .Font.Name = "WingDings"
            .Font.Color = vbRed
            '.Font.Bold = True
            .Font.Size = 16
            .Value = s
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Columns(1).EntireColumn.AutoFit
            .Interior.ColorIndex = xlNone
            .CopyPicture Appearance:=xlScreen, Format:=xlPicture
        End With

        ws.Pictures.Paste

        Set pic = ws.Pictures(ws.Pictures.Count)
        With cel.Offset(, 2)
            pic.Left = .Left
            pic.Top = .Top
        End With

        pic.Name = "picWingDing_" & s
    End If

    pic.CopyPicture Appearance:=xlScreen, Format:=xlPicture

End Sub

'''' end normal module

''''' code in a class named "clsChtEvents"

Public WithEvents cht As Excel.Chart
Private mbFlag As Boolean

' typically points per pixel is 72/96
' but should confirm with API
Const PP As Single = 0.75
Const mcPrefix As String = "picWD_"

Private Sub cht_MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal x
As Long, ByVal y As Long)
Dim pic As Picture
Const FF As Single = -3    ' a fudge factor, experiment !

    If Button = 1 And Shift = 2 Then    'left button & Ctrl
        MakeWingDingPic
        cht.Pictures.Paste
        Set pic = cht.Pictures(cht.Pictures.Count)
        With pic
            .Left = x * PP - .Width / 2 + FF
            .Top = y * PP - .Height / 2 + FF
        End With
        NamePic pic
        mbFlag = True
        cht.ChartArea.Select    ' try and deselect the picture
    ElseIf Shift = 6 Then ' Alt-Ctrl ' delete the pic's
        DelWDpics
    End If

End Sub

Private Sub cht_MouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal x
As Long, ByVal y As Long)
    If mbFlag Then
        mbFlag = False
        cht.ChartArea.Select
    End If
End Sub

Sub NamePic(pic As Picture)
Dim p As Picture
Dim i As Long
    On Error Resume Next
    Do
        i = i + 1
        Set p = cht.Pictures(mcPrefix & i)
    Loop Until Err.Number > 0
    pic.Name = mcPrefix & i
End Sub

Sub DelWDpics()
Dim p As Picture
    For Each p In cht.Pictures
        If InStr(p.Name, mcPrefix) = 1 Then
            p.Delete
        End If
    Next
End Sub

'''' end class clsChtEvents

Regards,
Peter T

Thanks, very much. Will reply shortly. (The PDF "pictures" I use are
actually drawings that architects converted from CAD)

 

[Pierre]

Thanks, very much. Will reply shortly. (The PDF "pictures" I use are
actually drawings that architects converted from CAD)- Hide quoted text -

- Show quoted text -

Peter,
I've done what you suggested but got stuck here: > > ''''' code in a
class named "clsChtEvents"

I inserted a new Class "Class1" and tried to rename it to
"clsChtEvents" to no avail.
Obviously the sub SetChart() won't run.
Please pardon my ignorance!
Pierre

 

[Peter T]

Select the Class module in Project Explorer (top left panel), in the
Properties window (typically bottom left panel but press F4 if necessary)
you should see
(Name) Class1

select "Class1" and rename to "clsChtEvents"

If for some reason you can't do that, replace clsChtEvents with "Class1" in
the normal module (I think in two places), and assuming the class you
inserted is named Class1.

Suggest head the modules "Option Explicit", which I see I forgot to include
in the post.

Sounds like this will be your first time to work with a class module (in
this case a "withevents class". Keep in mind the module is "instanced" with
the line
Set mcChart = New clsChtEvents

the class remains "alive" and responsive until the object reference
"mcChart" is destroyed, eg
Set mcChart = Nothing
note editing code can also destroy the object ref, you can run the SetChart
proc again if/when that ref' goes out of scope.

Regards,
Peter T

inserted a new Class "Class1" and tried to rename it to
"clsChtEvents" to no avail.
Obviously the sub SetChart() won't run.
Please pardon my ignorance!
Pierre

 

[Pierre]

Select the Class module in Project Explorer (top left panel), in the
Properties window (typically bottom left panel but press F4 if necessary)
you should see
(Name) Class1

select "Class1" and rename to "clsChtEvents"

If for some reason you can't do that, replace clsChtEvents with "Class1" in
the normal module (I think in two places), and assuming the class you
inserted is named Class1.

Suggest head the modules "Option Explicit", which I see I forgot to include
in the post.

Sounds like this will be your first time to work with a class module (in
this case a "withevents class". Keep in mind the module is "instanced" with
the line
Set mcChart = New clsChtEvents

the class remains "alive" and responsive until the object reference
"mcChart" is destroyed, eg
Set mcChart = Nothing
note editing code can also destroy the object ref, you can run the SetChart
proc again if/when that ref' goes out of scope.

Regards,
Peter T


inserted a new Class "Class1" and tried to rename it to
"clsChtEvents" to no avail.
Obviously the sub SetChart() won't run.
Please pardon my ignorance!
Pierre

Will do as directed. Your patience is appreciated.

 

[Pierre]

Will do as directed. Your patience is appreciated.- Hide quoted text -

- Show quoted text -

Hi Peter,
This discussion is starting look like a tutorial bur I really
apreciate your input.
I'm getting closer after following your latest suggestion. When I
click on the picture I get a small black square for a moment and then
it disappears.
However I got an error message on the following line in sub setchart

'' If Not cht Is Nothing Then
'' Set mcChart = New clsChtevents
'' Set mcChart.cht = cht Else ''''''''''''''''''''''''''''This
line is highlighted with the message "expected end of statement"
'' MsgBox "no chart on sheet"
'' End If
Ás you can see I made this piece of code "comments".and ran the sub
again with the above results.
I'm not sure what you mean by:
"With the chart selected press left button and Ctrl to paste a the
wingding picture (or Ctrl-Alt to delete them) "
When I do that the chart only moves to the left slightly.
Regards.
Pierre

 

[Peter T]

Hard to say why it's not working for you. I've just copy/pasted the code as
it appears in my newsreader. I can see the slight adjustment you made, need
to change

' If Not cht Is Nothing Then
' Set mcChart = New clsChtEvents
' Set mcChart.cht = cht Else
' MsgBox "no chart on sheet"
' End If

to

If Not cht Is Nothing Then
Set mcChart = New clsChtEvents
Set mcChart.cht = cht
Else: MsgBox "no chart on sheet"
End If

also had to unwrap a couple of lines in the class module

Made a new chart, ensured a picture is embedded in the chart (if you grab
and move the chart its picture should also move)

Selected the chart, ran "SetChart" (from F8).

To insert a little smiley face wingding image under the cursor, just click
the left button while holding control.

To delete all the wingding pictures (but not others such as the main
picture), hold Alt-Ctrl and click the left button.


If you can't get it working I can send you a demo.

Regards,
Peter T

PS Head the modules Option Explicit, Compile the project (under the Debug
menu)


Hi Peter,
This discussion is starting look like a tutorial bur I really
apreciate your input.
I'm getting closer after following your latest suggestion. When I
click on the picture I get a small black square for a moment and then
it disappears.
However I got an error message on the following line in sub setchart

'' If Not cht Is Nothing Then
'' Set mcChart = New clsChtevents
'' Set mcChart.cht = cht Else ''''''''''''''''''''''''''''This
line is highlighted with the message "expected end of statement"
'' MsgBox "no chart on sheet"
'' End If
Ás you can see I made this piece of code "comments".and ran the sub
again with the above results.
I'm not sure what you mean by:
"With the chart selected press left button and Ctrl to paste a the
wingding picture (or Ctrl-Alt to delete them) "
When I do that the chart only moves to the left slightly.
Regards.
Pierre

 

[Peter T]

I should have clarified the code is designed to work with an embedded chart
on a sheet, not a chart sheet. Also, for testing there's no particular need
to put your picture in the chart.

Peter T

 

[Pierre]

Hard to say why it's not working for you. I've just copy/pasted the code as
it appears in my newsreader. I can see the slight adjustment you made, need
to change

'    If Not cht Is Nothing Then
'        Set mcChart = New clsChtEvents
'        Set mcChart.cht = cht    Else
'        MsgBox "no chart on sheet"
'    End If

to

    If Not cht Is Nothing Then
        Set mcChart = New clsChtEvents
        Set mcChart.cht = cht
       Else: MsgBox "no chart on sheet"
    End If

also had to unwrap a couple of lines in the class module

Made a new chart, ensured a picture is embedded in the chart (if you grab
and move the chart its picture should also move)

Selected the chart, ran "SetChart" (from F8).

To insert a little smiley face wingding image under the cursor, just click
the left button while holding control.

To delete all the wingding pictures (but not others such as the main
picture), hold Alt-Ctrl and click the left button.

If you can't get it working I can send you a demo.

Regards,
Peter T

PS Head the modules Option Explicit, Compile the project (under the Debug
menu)


Hi Peter,
This discussion is starting look like a tutorial bur I really
apreciate your input.
I'm getting closer after following your latest suggestion. When I
click on the picture I get a small black square for a moment and then
it disappears.
However I got an error message on the following line in sub setchart

'' If Not cht Is Nothing Then
   ''  Set mcChart = New clsChtevents
    ''  Set mcChart.cht = cht Else  ''''''''''''''''''''''''''''This
line is highlighted with the message "expected end of statement"
   ''   MsgBox "no chart on sheet"
'' End If
Ás you can see I made this piece of code "comments".and ran the sub
again with the above results.
I'm not sure what you mean by:
"With the chart selected press left button and Ctrl to paste a the
wingding picture (or Ctrl-Alt to delete them) "
When I do that the chart only moves to the left slightly.
Regards.
Pierre

Peter,
I think a demo would be useful, thanks. I assume that my e-mail
details wilol be available in my profile. I am not sure whether I
should place it in the message.
Thanks.