charts on a User Form?

[jamiguel77]

i am interested on draw charts on a USer form, specially in a Multipagecontrol, how to do?

Thanks

 

[Jaafar Tribak]

@NdNoviceHlp

Thanks Jaafar for your time and efforts. My 32 bit 2016 installation doesn't seem to work... no hovering. This part of the code wouldn't compile with the extra end if or maybe I commented out the wrong one? Dave

Hi,

These version compatibility issues can get so annoying specially when one doesn't have a pc within reach for testing.

The followin fix, hopefully, should work fine :

I have also updated the example workbook.

Corrected Class Module code :

Option Explicit

Private WithEvents oWs As Worksheet
Private WithEvents Frm As MSForms.Frame
Private oChartSourceRange As Range
Private lCharYype As XlChartType
Private sTitle As String
Private bShowHoverToolTip As Boolean

Private Type POINTAPI
        X As Long
        Y As Long
End Type

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
       hPic As Long
       hPal As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

    Private hCopy As LongPtr, hPtr As LongPtr, hLib As LongPtr

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 

    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

    Private hCopy As Long, hPtr As Long, hLib As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const TOOLTIP_WIDTH = 135  [B][COLOR=#008000]'<== Const may need adjusting depending on lenghth of the caption text[/COLOR][/B]
Private Const TOOLTIP_HEIGHT = 25   [B][COLOR=#008000]'<== Const may need adjusting depending on lenghth of the caption text[/COLOR][/B]

Private Const IMAGE_BITMAP = 0
Private Const PICTYPE_BITMAP = 1
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2
Private Const S_OK = 0
Private Const COLOR_INFOBK = 24

Private oLbl As MSForms.Label
Private arrMarkersRects() As RECT
Private arrTipTexts() As String


Public Property Set FrameHost(ByVal Frame As MSForms.Frame)
    Set Frm = Frame
End Property

Public Property Set SourceRange(ByVal SourceRange As Range)
    Set oChartSourceRange = SourceRange
End Property

Public Property Let ChartType(ByVal ChType As XlChartType)
    lCharYype = ChType
End Property

Public Property Let ChartTitle(ByVal Title As String)
    sTitle = Title
End Property

Public Property Let ShowHoverToolTip(ByVal Show As Boolean)
    bShowHoverToolTip = Show
End Property

Public Sub Execute()
    If Not oChartSourceRange Is Nothing And Not Frm Is Nothing And lCharYype Then
        Call SetUpChart(oChartSourceRange, lCharYype, bShowHoverToolTip)
    Else
        MsgBox "Oops!" & vbCr & vbCr & "Verify that the Frame name, the Chart SourceRange and the ChartType are all correct", vbExclamation, "Error !"
    End If
End Sub


Private Sub Frm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Static bTipShowing As Boolean
    Dim p As POINTAPI, i As Long

    If bShowHoverToolTip Then
    
        p.X = X: p.Y = Y
        For i = 0 To UBound(arrMarkersRects)
          [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 And Win64 Then
                Dim lngPtr As LongPtr
                CopyMemory lngPtr, p, LenB(p)
                If PtInRect(arrMarkersRects(i), lngPtr) Then
                   If bTipShowing = False Then
                        bTipShowing = True
                        Call ShowToolTip(arrTipTexts(i), X, Y)
                    End If
                    Exit Sub
                 End If
            [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
                If PtInRect(arrMarkersRects(i), X, Y) Then
                    If bTipShowing = False Then
                        bTipShowing = True
                        Call ShowToolTip(arrTipTexts(i), X, Y)
                    End If
                    Exit Sub
                 End If
             [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
        Next i
        
        If bTipShowing = True Then
            oLbl.Visible = False
            bTipShowing = False
        End If
    
    End If
End Sub

Private Sub ShowToolTip(ByVal msg As String, ByVal X As Single, ByVal Y As Single)

    With oLbl
            .Caption = msg
            .Visible = 1
            .BackColor = GetSysColor(COLOR_INFOBK)
            .BorderStyle = fmBorderStyleSingle
            .Width = TOOLTIP_WIDTH [B][COLOR=#008000]' <== may need adjusting depending on lenghth of the caption text[/COLOR][/B]
            .Height = TOOLTIP_HEIGHT [B][COLOR=#008000]' <== may need adjusting depending on lenghth of the caption text[/COLOR][/B]
            .Left = X
            .Top = Y - 30
        End With
End Sub

Private Sub SetUpChart(ByVal SourceRange As Range, ByVal ChartType As XlChartType, ByVal HoverTip As Boolean)

    Dim tRect As RECT
    Dim vXValues As Variant, vValues As Variant
    Dim sngLeft As Single, sngTop As Single
    Dim i As Integer, j As Integer, iNextFirstPointIndex As Integer
    Dim sToolTipText As String
    
    On Error GoTo errHandler
    
    Frm.Caption = ""
    Application.EnableEvents = False
    SourceRange.Parent.Select
    Application.EnableEvents = True
    Set oLbl = Frm.Controls.Add("Forms.Label.1", "", 0)
    Set oWs = SourceRange.Parent
    SourceRange.Parent.Shapes.AddChart.Select
    
    With ActiveChart
        .SetSourceData Source:=SourceRange
        .ChartType = ChartType
        .SetElement (msoElementChartTitleAboveChart)
        .ChartTitle.Text = sTitle
        .Parent.Height = Frm.Height
        .Parent.Width = Frm.Width
        With .Parent.Chart.Legend.Format.TextFrame2.TextRange.Font
            .BaselineOffset = 0
            .Spacing = -1
        End With
           
        For i = 1 To .SeriesCollection.Count
        
            For j = 1 To .SeriesCollection(i).Points.Count
            
                sngLeft = ExecuteExcel4Macro("GET.CHART.ITEM(1,1,""S" & i & "P" & j & """)")
                sngTop = ExecuteExcel4Macro("GET.CHART.ITEM(2,1,""S" & i & "P" & j & """)")
                sngTop = (.ChartArea.Height - sngTop)
                
                vXValues = .SeriesCollection(i).XValues
                vValues = .SeriesCollection(i).Values
                
                ReDim Preserve arrMarkersRects(j + iNextFirstPointIndex)
                ReDim Preserve arrTipTexts(j + iNextFirstPointIndex)
                
                With tRect
                    .Left = sngLeft: .Top = sngTop
                    .Right = sngLeft + ActiveChart.SeriesCollection(i).MarkerSize: .Bottom = sngTop + ActiveChart.SeriesCollection(i).MarkerSize
                    arrMarkersRects(j + iNextFirstPointIndex) = tRect
                End With
                
                sToolTipText = "  Serie " & Chr(34) & .SeriesCollection(i).Name & Chr(34) & " Point " & Chr(34) & SourceRange(j + 1, 1) & Chr(34) _
                & vbNewLine & "  (" & vXValues(j) & "," & vValues(j) & ")"
                arrTipTexts(j + iNextFirstPointIndex) = sToolTipText
                
            Next j
            
            iNextFirstPointIndex = iNextFirstPointIndex + .SeriesCollection(i).Points.Count
        Next i
        
        Set Frm.Picture = CreatePicture(ActiveChart.Parent)
        
errHandler:

        .Parent.Delete
    End With
    
    Application.EnableEvents = True
End Sub
    
Private Function CreatePicture(ByVal Chart As ChartObject) As IPicture

    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
    Dim iPic As IPicture, lRet As Long
    
    On Error GoTo errHandler

    Chart.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hCopy
        .hPal = 0
    End With
    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, iPic)
    Else
        lRet = OleCreatePictureIndirectPro(uPicinfo, IID_IDispatch, True, iPic)
    End If
    FreeLibrary hLib
    If lRet = S_OK Then
        Set CreatePicture = iPic
    End If
errHandler:
    EmptyClipboard
    CloseClipboard
End Function

Private Sub oWs_Change(ByVal Target As Range)
    If Not Intersect(Target, oChartSourceRange) Is Nothing Then
        Call Execute
    End If
End Sub

 

[NdNoviceHlp]

Perfect. Seems to work flawlessly. Very cool. Thanks so much. Dave

 

[Jaafar Tribak]

Perfect. Seems to work flawlessly. Very cool. Thanks so much. Dave

You are welcome Dave.

I too I have learnt while trying to answer the questions asked in this thread.

 

[jamiguel77]

@Jaafar Tribak

thanks for answer i have some things:
1) in the next code in line:
oSrcRange.Parent.Select

i get an error checked and the range have values (also checked the all range in property: FormulaR1C1 and have all values that i need):

- : FormulaR1C1 : : Variant/Variant(1 to 4, 1 to 2) : CUserFormChart.SetUpChart

Private Sub SetUpChart()

    Dim oChart As ChartObject, oPoint As Point, i As Long

    On Error GoTo erHandler
    oFrame.Caption = ""
    oFrame.Parent.Parent.Parent.OptionButton1.Value = 1
    Application.EnableEvents = False
    oSrcRange.Parent.Select
    Application.EnableEvents = True
    Set ws = oSrcRange.Parent
    Set oLbl = oFrame.Controls.Add("Forms.Label.1", "Test", 0)
    Set oChart = CreateChart(oSrcRange, lChrType)
    arrColors = Array(255, 15773696, 5287936, 65535, 10498160, 16776960, 16711935, 49407, 192, 5296274, 16777215, 16711680, 8421504, 0)
    arrColorNames = Array("Red", "Light Blue", "Green", "Yellow", "Purple", "Cyan", "Pink", "Orange", "Dark Red", "Light Green", "White", "Blue", "Grey", "Black")
    For i = 1 To oChart.Chart.SeriesCollection(1).Points.Count
        ReDim Preserve arrLabelValues(i)
        arrLabelValues(i) = oChart.Chart.SeriesCollection(1).Points(i).DataLabel.Caption
        oChart.Chart.SeriesCollection(1).Points(i).Format.Fill.ForeColor.RGB = arrColors(i - 1)
    Next
    Set oFrame.Picture = CreatePicture(oChart)
erHandler:
    oChart.Delete
    Application.EnableEvents = True
End Sub

for continue work i commented the line: oSrcRange.Parent.Select <-- how to fix?


Question 2) i adapted the VBA code, and work if i click on a Red color, say me the color and the value, but is possible, personalize for each chart, the click event?

by sample:
if i click on a red area with a value of: 373 i want display the 'detail' of these 373 value:

100 apples
101 oranges
85 bananas
87 grape
=373

thanks......

much tahnks for your help and your patience....

 

[jamiguel77]

Happy new year to all
@Jaffar Tribak

other question

i create this graphs on a sheet, with this vba code:

Set rng = Range("A3:B5")
      Set cht = NewSheet.ChartObjects.Add( _
        Left:=200, _
        Width:=370, _
        Top:=7, _
        Height:=260)
      'cht.Chart.ChartType = xlPie
      cht.Chart.SetSourceData Source:=rng
      'cht.Chart.ChartType = xlPie
      cht.Chart.ChartType = xlDoughnut
      cht.Chart.HasTitle = True
      cht.Chart.ChartTitle.Text = "Budget 2018"
      'cht.Chart.SetElement msoElementDataLabelBestFit
      cht.Chart.SetElement msoElementDataLabelShow
      cht.Name = "xBudget"
      ActiveSheet.Shapes("xBudget").Line.Visible = msoFalse

if you see: i use: cht.Name = "xBudget" (of course each graph have unique name, i have 9 charts at this moment).

is possible link these charts via chart name, here:

 Set oChart1 = New CUserFormChart
 With oChart1
      Set .FrameHost = Me.MultiPage1.Pages(0).Frame1
      Set .SourceRange = NewSheet.Range("A2:B5")
      .ChartType = xlDoughnut
      .ChartTitle = NewSheet.Range("A1").Text
      .Execute
  End With

something:

  oChart1.Chart = ActiveSheet.Shapes("xBudget")

or

With oChart1
      Set .FrameHost = Me.MultiPage1.Pages(0).Frame1
      Set .SourceRange = ActiveSheet.Shapes("xBudget").Range    'Something
      .ChartType = xlDoughnut
      .ChartTitle = NewSheet.Range("A1").Text
      .Execute
  End With

Thanks

 

[jamiguel77]

@Jaafar Tribak hi friend are you there?

Any advice?

thanks

 

[jamiguel77]

hi, @Jaafar Tribak hi friend are you there?

thanks

 

[Jaafar Tribak]

hi, @Jaafar Tribak hi friend are you there?

thanks

Hi Jamiguel77,

Sorry I have just seen this ... The code is rather involved and I am quite busy at the moment so I'll need some quiet time to take a look at it

Regards.

 

[jamiguel77]

@Jaafar Tribak Thanks, and can you see a private message? thanks

 

[Jaafar Tribak]

@Jaafar Tribak Thanks, and can you see a private message? thanks

Hi jamiguel77,

Yes, I saw the PMs ... I'll take a new look at the code but as I said, the code is rather involved as is, so I am afraid, I will need to have some free time to take another look.

Regards.