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
Set wbk2 = Workbooks.Open(FileName:=F2)
Set wbk = Workbooks.Open(FileName:=F1)
Private Sub SetUpChart()
Dim oChart As ChartObject, oPoint As Point, i As Long
On Error GoTo erHandler
Set NewSheet = wbk.Sheets("Graficas")
Chart_Source_Range = NewSheet.Range("K66:L78")
erHandler:
oChart.Delete
Application.EnableEvents = True
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 Sub SetUpChart()
Dim oChart As ChartObject, oPoint As Point, i As Long
On Error GoTo erHandler
Set NewSheet = wbk.Sheets("Graficas")
'Range("A1:B1").Select
Chart_Source_Range = NewSheet.Range("K66:L78")
"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.
Option Explicit
Private WithEvents ws As Worksheet
Private WithEvents oFrame As MSForms.Frame
Private oSrcRange As Range
Private lChrType As XlChartType
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 Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) 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 Declare Function GetSysColor Lib "user32" (ByVal nIndex 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 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 arrColors() As Variant
Private arrColorNames() As Variant
Private arrLabelValues() As String
Private oLbl As MSForms.Label
Public Property Set SourceRange(ByVal SrcRange As Range)
Set oSrcRange = SrcRange
End Property
Public Property Let ChartType(ByVal ChrType As Variant)
lChrType = ChrType
If lChrType <> xlDoughnut And lChrType <> xlPie Then MsgBox "Only 'xlDoughnut' and 'xlPie' charts are allowed.", vbExclamation: End
End Property
Public Property Set FrameHost(ByVal Frm As MSForms.Frame)
Set oFrame = Frm
End Property
Public Sub Execute()
If Not oSrcRange Is Nothing And Not oFrame Is Nothing And lChrType Then
Call SetUpChart
End If
End Sub
Private Sub oFrame_Click()
Dim tCurPos As POINTAPI, lPixColor As Long
Dim sColor As String, sValue As String, lErr As Long
If oFrame.Parent.Parent.Parent.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 oFrame_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 oFrame.Parent.Parent.Parent.OptionButton1.Value = 0 Then
Call GetValues(sColor, sValue, lErr)
With oLbl
If lErr = 0 Then
.Caption = "Color : " & sColor & vbCr & "Value : " & sValue
.Visible = 1
.BackColor = GetSysColor(COLOR_INFOBK)
.BorderStyle = fmBorderStyleSingle
.Left = X
.Top = Y - 30
.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
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
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
.Parent.Height = oFrame.Height
.Parent.Width = oFrame.Width
.ChartType = ChartType
.SetSourceData Source:=oSrcRange
.SeriesCollection(1).ApplyDataLabels
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, oSrcRange) Is Nothing Then
Call SetUpChart
End If
End Sub
Option Explicit
Private oChart1 As CUserFormChart
Private oChart2 As CUserFormChart
Private oChart3 As CUserFormChart
Private Sub UserForm_Initialize()
Set oChart1 = New CUserFormChart
Set oChart2 = New CUserFormChart
Set oChart3 = New CUserFormChart
With Me.MultiPage1
.Pages(0).Caption = "Chart 1"
.Pages(1).Caption = "Chart 2"
.Pages(2).Caption = "Chart 3"
.Value = 0
End With
With oChart1
Set .FrameHost = Me.MultiPage1.Pages(0).Frame1
Set .SourceRange = Sheet1.Range("A1:B9")
.ChartType = xlDoughnut
.Execute
End With
With oChart2
Set .FrameHost = Me.MultiPage1.Pages(1).Frame2
Set .SourceRange = Sheet1.Range("A12:B20")
.ChartType = xlPie
.Execute
End With
'
With oChart3
Set .FrameHost = Me.MultiPage1.Pages(2).Frame3
Set .SourceRange = Sheet1.Range("A23:B31")
.ChartType = xlDoughnut
.Execute
End With
End Sub
Option Explicit
Private WithEvents ws As Worksheet
Private WithEvents oFrame As MSForms.Frame
Private oSrcRange As Range
Private lChrType As XlChartType
Private sTitle As String
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 Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) 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 Declare Function GetSysColor Lib "user32" (ByVal nIndex 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 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 arrColors() As Variant
Private arrColorNames() As Variant
Private arrLabelValues() As String
Private oLbl As MSForms.Label
Public Property Set SourceRange(ByVal SrcRange As Range)
Set oSrcRange = SrcRange
End Property
Public Property Let ChartType(ByVal ChrType As Variant)
lChrType = ChrType
If lChrType <> xlDoughnut And lChrType <> xlPie Then MsgBox "Only 'xlDoughnut' and 'xlPie' charts are allowed.", vbExclamation: End
End Property
Public Property Let ChartTitle(ByVal Title As String)
sTitle = Title
End Property
Public Property Set FrameHost(ByVal Frm As MSForms.Frame)
Set oFrame = Frm
End Property
Public Sub Execute()
If Not oSrcRange Is Nothing And Not oFrame Is Nothing And lChrType Then
Call SetUpChart
End If
End Sub
Private Sub oFrame_Click()
Dim tCurPos As POINTAPI, lPixColor As Long
Dim sColor As String, sValue As String, lErr As Long
If oFrame.Parent.Parent.Parent.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 oFrame_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 oFrame.Parent.Parent.Parent.OptionButton1.Value = 0 Then
Call GetValues(sColor, sValue, lErr)
With oLbl
If lErr = 0 Then
.Caption = "Color : " & sColor & vbCr & "Value : " & sValue
.Visible = 1
.BackColor = GetSysColor(COLOR_INFOBK)
.BorderStyle = fmBorderStyleSingle
.Left = X
.Top = Y - 30
.Font.Bold = True
.Height = 25 [B][COLOR=#008000]'<== may need adjusting depending on lenghth of the caption text[/COLOR][/B]
.Width = 80 [B][COLOR=#008000]'<== may need adjusting depending on lenghth of the caption text[/COLOR][/B]
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
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
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
.Parent.Height = oFrame.Height
.Parent.Width = oFrame.Width
.ChartType = ChartType
.SetSourceData Source:=SourceDataRange
.SetElement (msoElementChartTitleAboveChart)
.ChartTitle.Text = sTitle
.SeriesCollection(1).ApplyDataLabels
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, oSrcRange) Is Nothing Then
Call SetUpChart
End If
End Sub
Option Explicit
Private oChart1 As CUserFormChart
Private oChart2 As CUserFormChart
Private oChart3 As CUserFormChart
Private Sub UserForm_Initialize()
Set oChart1 = New CUserFormChart
Set oChart2 = New CUserFormChart
Set oChart3 = New CUserFormChart
With Me.MultiPage1
.Pages(0).Caption = "Chart 1"
.Pages(1).Caption = "Chart 2"
.Pages(2).Caption = "Chart 3"
.Value = 0
End With
With oChart1
Set .FrameHost = Me.MultiPage1.Pages(0).Frame1
Set .SourceRange = Sheet1.Range("A2:B9")
.ChartType = xlDoughnut
.ChartTitle = Range("A1").Text
.Execute
End With
With oChart2
Set .FrameHost = Me.MultiPage1.Pages(1).Frame2
Set .SourceRange = Sheet1.Range("A13:B20")
.ChartType = xlPie
.ChartTitle = Range("A12").Text
.Execute
End With
'
With oChart3
Set .FrameHost = Me.MultiPage1.Pages(2).Frame3
Set .SourceRange = Sheet1.Range("A24:B31")
.ChartType = xlDoughnut
.ChartTitle = Range("A23").Text
.Execute
End With
End Sub
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 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 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 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 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 [COLOR=#008000][B]'<== Const may need adjusting depending on lenghth of the caption text[/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 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 Then
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL] Win64 Then
Dim lngPtr As LongPtr
CopyMemory lngPtr, p, LenB(p)
If PtInRect(arrMarkersRects(i), lngPtr) Then
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL] If
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL]
If PtInRect(arrMarkersRects(i), X, Y) Then
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL] If
If bTipShowing = False Then
bTipShowing = True
Call ShowToolTip(arrTipTexts(i), X, Y)
End If
Exit Sub
End If
Next
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
Option Explicit
Private oChart1 As CUserFormChart
Private oChart2 As CUserFormChart
Private Sub UserForm_Initialize()
Set oChart1 = New CUserFormChart
Set oChart2 = New CUserFormChart
With Me.MultiPage1
.Pages(0).Caption = "Chart 1"
.Pages(1).Caption = "Chart 2"
.Value = 0
End With
With oChart1
Set .FrameHost = Me.MultiPage1.Pages(0).Frame1
Set .SourceRange = Sheet1.Range("A3:D15")
.ChartType = xlXYScatter
.ChartTitle = Sheet1.Range("A2").Text
.ShowHoverToolTip = True
.Execute
End With
With oChart2
Set .FrameHost = Me.MultiPage1.Pages(1).Frame2
Set .SourceRange = Sheet1.Range("A19:D31")
.ChartType = xlXYScatterSmooth
.ChartTitle = Sheet1.Range("A18").Text
.ShowHoverToolTip = True
.Execute
End With
End Sub
Option Explicit
Private oChart1 As CUserFormChart
Private oChart2 As CUserFormChart
Private Sub UserForm_Initialize()
Set oChart1 = New CUserFormChart
Set oChart2 = New CUserFormChart
With oChart1
Set .FrameHost = Me.Frame1
Set .SourceRange = Sheet1.Range("A3:D15")
.ChartType = xlXYScatter
.ChartTitle = Sheet1.Range("A2").Text
.ShowHoverToolTip = True
.Execute
End With
With oChart2
Set .FrameHost = Me.Frame2
Set .SourceRange = Sheet1.Range("A19:D31")
.ChartType = xlRadarMarkers
.ChartTitle = Sheet1.Range("A18").Text
.ShowHoverToolTip = True
.Execute
End With
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)
#If VBA7 Then
#If Win64 Then
Dim lngPtr As LongPtr
CopyMemory lngPtr, p, LenB(p)
If PtInRect(arrMarkersRects(i), lngPtr) Then
#End If
#Else
If PtInRect(arrMarkersRects(i), X, Y) Then
#End If
If bTipShowing = False Then
bTipShowing = True
Call ShowToolTip(arrTipTexts(i), X, Y)
End If
Exit Sub
'End If
Next
If bTipShowing = True Then
oLbl.Visible = False
bTipShowing = False
End If
End If
End Sub