View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.programming
Peter T Peter T is offline
external usenet poster
 
Posts: 5,600
Default Place wingding on specific coordinates - possible?

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