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
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
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
"Private Const Chart_Source_Range = "Sheet1!$A$1:$B$9" ' <== Change Chart Source address as required"
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