charts on a User Form?

J

jamiguel77

Active Member
Joined
Feb 14, 2006
Messages
387
Office Version
  1. 2016
  2. 2010
  3. 2007
Platform
  1. Windows
  2. Web
i am interested on draw charts on a USer form, specially in a Multipagecontrol, how to do?

Thanks
 
Sort by date Sort by votes
That's a lot of code to understand.
It looks like it's saving the chart image to a file on your computer then loading that image into the userform.

I thought if their is a Chart on the sheet it can be converted to a image to be shown in the Userform without saving the image to the computer file.

But I guess not.

Thanks for that code. Maybe the original poster cab use that.
 
Upvote 0

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Your somewhat mistaken. You save the chart as an image file then load it to the image control on the userform and then kill the file. So, your right that U need to store the chart, but only temporarily as you're not really saving it. If U talk nice to Jafaar, he has some code to take a picture of the range that the chart is on the sheet and then U can put it in a frame control on the userform that U can scroll the chart in. As far as updating the chart image in the userform control, update the chart itself, make a new pic file by either route, and then replace the image on the userform. HTH. Dave
 
Upvote 0
hi friends:

here a image of my UF:

https://imgur.com/a/PvyzK4K

my dude is: how to determine if user click on blue area (1) and display: blue and the value 383? its a image? ir wich recommend me for display the labels?

thanks
 
Upvote 0
Your last post was somewhat cryptic and hard to understand but as Jafaar suggested, U need to add the labels to the chart before U make a picture of it. And no, U can't hover the pointer over a chart image and expect it to do anything... it's just a picture. HTH. Dave
ps. I should likely retract the "U can't" as Jafaar probably can figure out how to do it with some fancy API stuff. Something like correlating your pointer position on the chart image to the corresponding pointer position of the actual chart then replacing the chart image with the actual chart... sound challenging.
 
Last edited:
Upvote 0
I gave this a shot and came up with the following which hopefully responds to clicking the individual Pie chart areas as requested.

I also added an alternative choice to show a screentip on mouse over instead of a MsgBox.

Also, the code doesn't require to temporarly save the chart image to disk. It just copies it to the clipboard with API calls.

Limitations:
The code as is works only for Pie-like charts with one Dataserie and no 3D effects .

Workbook Demo





Code in the UserForm Module:
Code: 
Option Explicit

Private WithEvents ws As Worksheet

Private Type POINTAPI
        X As Long
        Y 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
    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 GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    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 hCopy As LongPtr, hPtr As LongPtr, hdc As LongPtr, hLib As LongPtr

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) 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 hCopy As Long, hPtr As Long, hdc As Long, hLib As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


Private Const Chart_Source_Range = "Sheet1!$A$1:$B$9"     [B][COLOR=#008000]' <== Change Chart Source addrs as required[/COLOR][/B]

[B][COLOR=#008000]' --- (3D Chart Types won't work)[/COLOR][/B]
Private Const PIE_CHART_TYPE = xlDoughnut    [B][COLOR=#008000] ' <== Change Pie Chart Type to ( xlDoughnutExploded,  xlPie,  xlPieOfPie, xlPieExploded etc..)[/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 arrColors() As Variant
Private arrColorNames() As Variant
Private arrLabelValues() As String
Private oLbl As MSForms.Label


Private Sub UserForm_Initialize()
    Call SetUpChart
End Sub

Private Sub UserForm_Terminate()
    ReleaseDC 0, hdc
End Sub


Private Sub Frame1_Click()

    Dim tCurPos As POINTAPI, lPixColor As Long
    Dim sColor As String, sValue As String, lErr As Long
    
    If Me.OptionButton1.Value = -1 Then
        Call GetValues(sColor, sValue, lErr)
        If sColor <> "White" Then
            MsgBox "Color : " & sColor & vbCr & "Value : " & sValue, vbInformation
        End If
    End If
End Sub


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

    Dim sColor As String, sValue As String, lErr As Long
    
    If Me.OptionButton1.Value = 0 Then
        Call GetValues(sColor, sValue, lErr)
        With oLbl
        If lErr = 0 Then
            .Caption = "Color : " & sColor & vbCr & "Value : " & sValue
            .Visible = 1
            .BackColor = &HC0FFFF
            .BorderStyle = fmBorderStyleSingle
            .Left = X
            .Top = Y + 15
            .Font.Bold = True
            .Height = 25  [B][COLOR=#008000]'<== may need adjusting depending on lenghth of the caption text[/COLOR][/B]
            .Width = 80   [COLOR=#008000][B]'<== may need adjusting depending on lenghth of the caption text[/B][/COLOR]
        End If
        If sColor = "White" Then
            .Visible = 0
        End If
        End With
    End If
End Sub


Private Sub SetUpChart()

    Dim oChart As ChartObject, oPoint As Point, i As Long
    
    On Error GoTo erHandler
    Me.Frame1.Caption = ""
    Me.OptionButton1.Value = 1
    Application.EnableEvents = False
    Range(Chart_Source_Range).Parent.Select
    Application.EnableEvents = True
    Set ws = Range(Chart_Source_Range).Parent
    Set oLbl = Me.Frame1.Controls.Add("Forms.Label.1", "Test", 0)
    hdc = GetDC(0)
    Set oChart = CreateChart(Range(Chart_Source_Range), PIE_CHART_TYPE)
    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 Me.Frame1.Picture = CreatePicture(oChart)
erHandler:
    oChart.Delete
    Application.EnableEvents = True
End Sub


Private Sub GetValues(ByRef Color As String, ByRef Value As String, ByRef ErrorNumber As Long)

    Dim tCurPos As POINTAPI, lPixColor As Long
    
    On Error Resume Next
    GetCursorPos tCurPos
    lPixColor = GetPixel(hdc, tCurPos.X, tCurPos.Y)
    Color = arrColorNames(Application.Match(lPixColor, arrColors, 0) - 1)
    Value = arrLabelValues(Application.Match(lPixColor, arrColors, 0))
    ErrorNumber = Err.Number
End Sub
        
        
Private Function CreateChart(ByVal SourceDataRange As Range, ByVal ChartType As XlChartType) As ChartObject
    SourceDataRange.Parent.Shapes.AddChart.Select
    With ActiveChart
        .ChartType = ChartType
        .SetSourceData Source:=SourceDataRange
        .SeriesCollection(1).ApplyDataLabels
        .Parent.Height = Me.Frame1.Height
        .Parent.Width = Me.Frame1.Width
        With .Parent.Chart.Legend.Format.TextFrame2.TextRange.Font
            .BaselineOffset = 0
            .Spacing = -1
        End With
        Set CreateChart = .Parent
    End With
End Function
    
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 ws_Change(ByVal Target As Range)
    If Not Intersect(Target, Range(Chart_Source_Range)) Is Nothing Then
        Call SetUpChart
    End If
End Sub
 
Upvote 0
ooo interesting, i test in this weekend the code and return to ask dudes.

i want "Detect" click and know wich area is, for know th detail of 383.

we know Prod=383

i want display other Grapth with the detail of 383, sample:

sweeper 75
painter 120
chef 28
welder 95
miner 65
--------------
383


with this code you provideed me is a start.

Thanks thanks
 
Upvote 0
The previous code had a subtle bug which I have now fixed in the following code update:

Workbook update

Code: 
Option Explicit

Private WithEvents ws As Worksheet

Private Type POINTAPI
        X As Long
        Y 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
    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 GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    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 hCopy As LongPtr, hPtr As LongPtr, hdc As LongPtr, hLib As LongPtr

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) 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 hCopy As Long, hPtr As Long, hdc As Long, hLib As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const Chart_Source_Range = "Sheet1!$A$1:$B$9"     [B][COLOR=#008000]' <== Change Chart Source addrs as required[/COLOR][/B]

[B][COLOR=#008000]' --- (3D Chart Types won't work)[/COLOR][/B]
Private Const PIE_CHART_TYPE = xlDoughnut    [COLOR=#008000][B] ' <== Change Pie Chart Type to ( xlDoughnutExploded,  xlPie,  xlPieOfPie, xlPieExploded etc..)[/B][/COLOR]

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 arrColors() As Variant
Private arrColorNames() As Variant
Private arrLabelValues() As String
Private oLbl As MSForms.Label


Private Sub UserForm_Initialize()
    Call SetUpChart
End Sub


Private Sub Frame1_Click()

    Dim tCurPos As POINTAPI, lPixColor As Long
    Dim sColor As String, sValue As String, lErr As Long
    
    If Me.OptionButton1.Value = -1 Then
        Call GetValues(sColor, sValue, lErr)
        If sColor <> "White" Then
            MsgBox "Color : " & sColor & vbCr & "Value : " & sValue, vbInformation
        End If
    End If
End Sub


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

    Dim sColor As String, sValue As String, lErr As Long
    
    If Me.OptionButton1.Value = 0 Then
        Call GetValues(sColor, sValue, lErr)
        With oLbl
        If lErr = 0 Then
            .Caption = "Color : " & sColor & vbCr & "Value : " & sValue
            .Visible = 1
            .BackColor = &HC0FFFF
            .BorderStyle = fmBorderStyleSingle
            .Left = X
            .Top = Y + 15
            .Font.Bold = True
            .Height = 25  [B][COLOR=#008000]'<== may need adjusting depending on lenghth of the caption text[/COLOR][/B]
            .Width = 80   [COLOR=#008000][B]'<== may need adjusting depending on lenghth of the caption text[/B][/COLOR]
        End If
        If sColor = "White" Then
            .Visible = 0
        End If
        End With
    End If
End Sub


Private Sub SetUpChart()

    Dim oChart As ChartObject, oPoint As Point, i As Long
    
    On Error GoTo erHandler
    Me.Frame1.Caption = ""
    Me.OptionButton1.Value = 1
    Application.EnableEvents = False
    Range(Chart_Source_Range).Parent.Select
    Application.EnableEvents = True
    Set ws = Range(Chart_Source_Range).Parent
    Set oLbl = Me.Frame1.Controls.Add("Forms.Label.1", "Test", 0)
    Set oChart = CreateChart(Range(Chart_Source_Range), PIE_CHART_TYPE)
    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 Me.Frame1.Picture = CreatePicture(oChart)
erHandler:
    oChart.Delete
    Application.EnableEvents = True
End Sub


Private Sub GetValues(ByRef Color As String, ByRef Value As String, ByRef ErrorNumber As Long)

    Static tCurPos As POINTAPI
    Static lPixColor As Long
    
    On Error Resume Next
    hdc = GetDC(0)
    GetCursorPos tCurPos
    lPixColor = GetPixel(GetDC(0), tCurPos.X, tCurPos.Y)
    ReleaseDC 0, hdc
    Color = arrColorNames(Application.Match(lPixColor, arrColors, 0) - 1)
    Value = arrLabelValues(Application.Match(lPixColor, arrColors, 0))
    ErrorNumber = Err.Number
End Sub
        
        
Private Function CreateChart(ByVal SourceDataRange As Range, ByVal ChartType As XlChartType) As ChartObject
    SourceDataRange.Parent.Shapes.AddChart.Select
    With ActiveChart
        .ChartType = ChartType
        .SetSourceData Source:=SourceDataRange
        .SeriesCollection(1).ApplyDataLabels
        .Parent.Height = Me.Frame1.Height
        .Parent.Width = Me.Frame1.Width
        With .Parent.Chart.Legend.Format.TextFrame2.TextRange.Font
            .BaselineOffset = 0
            .Spacing = -1
        End With
        Set CreateChart = .Parent
    End With
End Function
    
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 ws_Change(ByVal Target As Range)
    If Not Intersect(Target, Range(Chart_Source_Range)) Is Nothing Then
        Call SetUpChart
    End If
End Sub

@jamiguel77
I am not sure I understood you .. Are you saying the code worked for you or it didn't work ?
Also, are you wanting this for another chart ? and if so, do you want it in the same userform ?
 
Upvote 0
"I gave this a shot"... I was sure hoping that U would Jaafar... that is some cool stuff. Is it possible to get the hover tool tip thing to work for a series in a scatter chart? I would have some use for that. If U think it is, I would have a go at it, being that I would like to learn a bit more about API coding. Maybe I'll add some set up instructions for others: Add a userform. Place a frame control and x2 option buttons on the userform. Place data in the range U define in this part of the code within the declarations:
Code: 
"Private Const Chart_Source_Range = "Sheet1!$A$1:$B$9"     ' <== Change Chart Source address as required"
Code to Show the userform and that's it. Thanks for your brilliant "shot" Jaafar.
Dave
ps. I really like the cool animated presentation of your previous post.
 
Upvote 0
Hi Jaafar, thanks for answer....

not tested the code at this moment....
and i want display the Detail Graph, in other Userform (or in a Multitab page).

The process is: if user click on 383 pie Area, i want display other grap with this data: (same circular graph):

sweeper 75
painter 120
chef 28
welder 95
miner 65
--------------
383


Thanks
 
Upvote 0
Strange i have 6 charts on my excel file..... but when generate the GIF picture of each one, in this line:

myCh.Export FileName:=imageName

only create the first two.... why?

the rest isnt created.... (Created with 0 bytes size...

i try before create the variable:

'myCh.ChartArea.ClearContents
'myCh.ChartArea.Clear

but get an error, thanks


Here complete code of my function:

Code: 
Private Sub llenaTablaGrafica(wRow1 As Integer, wCol1 As Integer, wRow2 As Integer, wRow3 As Integer, wCol2 As Integer, wCol3 As Integer, wCol4 As Integer, _
                              wNCol1 As Integer, wNCol2 As Integer, wRange1 As String, wLeft As Integer, wTop As Integer, wChartTitle As String, wChartName As String, _
                              wevalua As Integer)
   Dim wavanza As Integer
   wavanza = 1
   wauxValor = xActiveSheet.Cells(wRow1, wCol1)
   Dim wai As Integer
   wai = wRow2
   wxi = wRow1
   Do While wauxValor <> "Total"
      wauxValor = xActiveSheet.Cells(wxi, wCol2)
      waux1 = xActiveSheet.Cells(wxi, wCol3)
      waux2 = xActiveSheet.Cells(wxi, wCol4)
      waux3 = xActiveSheet.Cells(wxi, wCol1 + 1)
      If wevalua = 0 Then
        wavanza = 0
        If Trim(waux1) = "" Then
          If Trim(wauxValor) <> "" Then
            If InStr(wauxValor, "Total") = 0 Then
              wavanza = 1
            End If
          End If
        End If
      Else
        wavanza = 0
        If InStr(wauxValor, "Total") = 0 Then
          wavanza = 1
        End If
      End If
      If wavanza = 1 Then
        NewSheet.Cells(wai, wNCol1) = wauxValor
        NewSheet.Cells(wai, wNCol2) = waux2
        NewSheet.Cells(wai, wNCol1 - 1) = waux3
        NewSheet.Cells(wai, wNCol1).Font.Size = 9
        NewSheet.Cells(wai, wNCol2).Font.Size = 9
        wai = wai + 1
      End If
      wxi = wxi + 1
   Loop
   wai = wai - 1
   Set rng = Range(wRange1 & wai)
   With rng.Borders
     .LineStyle = xlContinuous
     .Color = vbBlack
     .Weight = xlThin
   End With
   Set cht = NewSheet.ChartObjects.Add( _
     Left:=wLeft, _
     Width:=370, _
     Top:=wTop, _
     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 = wChartTitle
   'cht.Chart.SetElement msoElementDataLabelBestFit
   cht.Chart.SetElement msoElementDataLabelShow
   cht.Name = wChartName
   ActiveSheet.Shapes(wChartName).Line.Visible = msoFalse
   imageName = Application.DefaultFilePath & Application.PathSeparator & wChartName & ".gif"
   If Len(Dir$(imageName)) > 0 Then
     Kill imageName
   End If
   'myCh.ChartArea.ClearContents
   'myCh.ChartArea.Clear
   Set myCh = cht.Chart
   myCh.Export FileName:=imageName
   End Sub
 
Last edited by a moderator:
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Conditional Format Selected Cell
2
Replies
12
Views
169
Pacman52
P
P
  • Question Question
Show Login Form If Workbook In Active
Replies
3
Views
155
Pacman52
P
D
  • Solved
SUM of Columns based on multiple criteria with User Form
2
Replies
15
Views
294
Alex Blakenburg
A
G
  • Question Question
Bug with passing variables between user forms--VBA
Replies
4
Views
473
Domenic
D
T
  • Solved
Modifying a Donut Chart
Replies
3
Views
120
Kaper
Kaper

Forum statistics

Threads
1,223,893
Messages
6,175,246
Members
452,623
Latest member
cliftonhandyman

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top