VB Forum / General / July 2008

"Mike Williams" wrote in message

Thanks for that, and to Karl too who said pretty much the same thing.

I only brought this up as Jan Hyde had mentioned not wanting to rely on the
clipboard and it seemed like an intriguing idea (not that I've never had the
clipboard fail on me). Even if it was doable it would it would be limited to
an "active" chart only.

Regards,
Peter T

I didn't know you could simply paste an Excel chart (image) into an RTB.
There is another series of API's to extract the chart from the clipboard
into any control with a picture property, handy if it also has an AutoSize
property.

Following is along similar lines to RBS's but with some different Excel
methods, namely

- Data directly into series formulas (see the limitation note in the
comments, probably better in cells but just for ideas)

- Create an embedded chart, easier to size than a chart sheet

- for better re-scalability of the pasted chart and other things, use
cht.CopyPicture arg's
vs
cht.ChartArea.Copy

' in a Form with an RTB
' keep clicking the form

Option Explicit
Private Const xlLineMarkers As Long = 65
Private Const xlXYScatter As Long = -4169
Private Const xlColumns As Long = 2
Private Const xlLocationAsNewSheet As Long = 1

Private Const xlPicture As Long = -4147
Private Const xlScreen As Long = 1
Private Const xlBitmap As Long = 2

Private Declare Function SendMessage Lib "user32" _
                                    Alias "SendMessageA" _
                                    (ByVal hwnd As Long, _
                                     ByVal wMsg As Long, _
                                     ByVal wParam As Long, _
                                     lParam As Any) As Long
Private Const WM_PASTE As Long = 770
Private Const WM_LBUTTONDOWN As Long = 513
Private Const WM_LBUTTONUP As Long = 514

Dim moXL As Object, moCht As Chart

Sub ChartToRTB(Optional w As Single, Optional h As Single)
Dim vArr, x As Long
Dim oWB As Object, oWS As Object
Dim oSR As Object

   'normally better always create a new Excel instance
   ' but for developing  ...

On Error Resume Next    ' lazy just for this post
   If moXL Is Nothing Then
       Set moXL = GetObject(, "excel.application")
       '
       If moXL Is Nothing Then
           Set moXL = CreateObject("excel.application")
           moXL.Visible = True    ' for testing
       End If
       If moXL Is Nothing Then
       ' ?????????
           MsgBox Err.Description
           Exit Sub
       End If
   End If

'    Set oWB = moXL.Workbooks(sName)
'    If oWB Is Nothing Then
'        Set oWB = moXL.Workbooks.Open(sPath)
'    End If
   Set oWB = moXL.ActiveWorkbook ' for testing

   If oWB Is Nothing Then
       Set oWB = moXL.Workbooks.Add
   End If

   Set oWS = oWB.Worksheets(1)

   Set moCht = oWS.ChartObjects(1).Chart

   If moCht Is Nothing Then
       If w = 0 Then w = 270    ' points
       If h = 0 Then h = 180

       Set moCht = oWS.ChartObjects.Add(10#, 10#, w, h).Chart
       moCht.ChartType = xlXYScatter

   Else
       If w Then moCht.Parent.Width = w
       If h Then moCht.Parent.Height = h

   End If

   Set oSR = moCht.SeriesCollection(1)
   If oSR Is Nothing Then
       Set oSR = moCht.SeriesCollection.NewSeries
       oSR.Name = "Apples"
   End If
   oSR.XValues = SomeArray(5)    ' * see note
   oSR.Values = SomeArray(10)

   Set oSR = Nothing
   Set oSR = moCht.SeriesCollection(2)
   If oSR Is Nothing Then
       Set oSR = moCht.SeriesCollection.NewSeries
       oSR.Name = "Pears"
   End If

   oSR.XValues = SomeArray(5)
   oSR.Values = SomeArray(10)

   With moCht.Axes(xlCategory, xlPrimary)
       .HasTitle = True
       .AxisTitle.Text = "Ripeness"
   End With

   With moCht.Axes(xlValue, xlPrimary)
       .HasTitle = True
       .AxisTitle.Text = "Size"
   End With

   moCht.HasTitle = True
   moCht.ChartTitle.Text = "Orchard"
   moCht.HasLegend = True
   moCht.PlotArea.Fill.ForeColor.SchemeColor = 2

   moCht.CopyPicture xlScreen, xlPicture, xlScreen
   SendMessage Form1.RichTextBox1.hwnd, WM_PASTE, 0, 0

   ' * Applying an array directly to sr.Values writes values
   '  into the series formula, no need for cells
   ' BUT will fail if len("{1,2,3.1,123.456}"} > 255
   ' (ie len all the values + comma's + curly brackets > 255
   ' within one "section" of the 4-part series formula

   ' Normal way is with series data in cells, record an Excel nacro
   '  record an Excel nacro to get the syntax
End Sub

Function SomeArray(x As Long)
Dim i&
Dim vArr

   ReDim vArr(1 To 10)
   For i = 1 To 10
       vArr(i) = Int(Rnd() * x) + 1
   Next

   SomeArray = vArr

End Function

Private Sub Form_Click()
   ChartToRTB

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   On Error Resume Next
'    If Not moXL Is Nothing Then
'        moXL.DisplayAlerts = False
'        ' careful all workbooks'll close w/out save
'        moXL.Quit
'    End If
End Sub

Above really is for ideas only and would need a lot more.

For testing, In Excel select the chart, Shift-Edit, Copy Picture. Try the
various options then Ctrl-V into the RTB.

Also record a macro to format the chart as required, new series etc to get
all the basic syntax (select & activate stuff will need to be removed), most
of which can be adapted into DoChart above.

Regards,
Peter T