jamiguel77
Active Member
- Joined
- Feb 14, 2006
- Messages
- 387
- Office Version
- 2016
- 2010
- 2007
- Platform
- Windows
- Web
i am interested on draw charts on a USer form, specially in a Multipagecontrol, how to do?
Thanks
Thanks
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
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
Perfect. Seems to work flawlessly. Very cool. Thanks so much. Dave
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
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
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
oChart1.Chart = ActiveSheet.Shapes("xBudget")
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
@Jaafar Tribak Thanks, and can you see a private message? thanks