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
|