Draw Smooth Transparent Shapes on Radar Chart

willytan

New Member
Joined
Jan 18, 2011
Messages
7
Hi guys,

I have tried to run the code given to draw smooth transparent shapes on radar chart, as suggested by Peltier as shown in the website below.

http://peltiertech.com/Excel/Charts/VBAdrawradar.html#SmoothTransShape

I believe some of you should be an expert in handling the chartin Excel, therefore your help will be greatly appreciated!

It seems there is some customization needed in order for this code to run smoothly at any excel file. You guys can help me to highlight anything that I might miss out on the code written.


Once again, thank you for your great assistance and help, guys! Looking forward to hearing back a good news from you guys soon!


Warmest Regards,
Willy

---

Sub DrawTransparentShapesOnRadarChart()
Dim cht As Chart
Dim srs As Series
Dim iSrs As Long
Dim Npts As Integer
Dim Ipts As Integer
Dim myShape As Shape
Dim Xnode As Double, Ynode As Double
Dim Rmax As Double, Rmin As Double
Dim Xleft As Double, Ytop As Double
Dim Xwidth As Double, Yheight As Double
Dim dPI As Double
Dim iFillColor As Long
Dim iLineColor As Long

'Dim Pict As Object
'Dim xlApp As Excel.Application
'Dim xlWB As Workbook

'Set xlApp = New Excel.Application
'Set xlWB = xlApp.Workbooks.Open(excelfile)
'Sheets("CMP Tool Capacity Model").Select
'Set Pict = ActiveSheet.ChartObjects("Chart 2")
Set cht = ActiveChart
Xleft = cht.PlotArea.InsideLeft
Xwidth = cht.PlotArea.InsideWidth
Ytop = cht.PlotArea.InsideTop
Yheight = cht.PlotArea.InsideHeight
Rmax = cht.Axes(2).MaximumScale
Rmin = cht.Axes(2).MinimumScale
dPI = WorksheetFunction.Pi()
For iSrs = 1 To cht.SeriesCollection.Count
Set srs = cht.SeriesCollection(iSrs)
Select Case srs.ChartType
Case xlRadar, xlRadarFilled, xlRadarMarkers
Npts = srs.Points.Count
Xnode = Xleft + Xwidth / 2 * (1 + (srs.Values(Npts) - Rmin) / (Rmax - Rmin) * Sin(2 * dPI * (Npts - 1) / Npts))
Ynode = Ytop + Yheight / 2 * (1 - (srs.Values(Npts) - Rmin) / (Rmax - Rmin) * Cos(2 * dPI * (Npts - 1) / Npts))
With cht.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)
For Ipts = 1 To Npts
Xnode = Xleft + Xwidth / 2 * (1 + (srs.Values(Ipts) - Rmin) / (Rmax - Rmin) * Sin(2 * dPI * (Ipts - 1) / Npts))
Ynode = Ytop + Yheight / 2 * (1 - (srs.Values(Ipts) - Rmin) / (Rmax - Rmin) * Cos(2 * dPI * (Ipts - 1) / Npts))

.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next
Set myShape = .ConvertToShape
End With
For Ipts = 1 To Npts
myShape.Nodes.SetEditingType 3 * Ipts - 2, msoEditingSmooth
Next
Select Case iSrs
Case 1
iFillColor = 44
iLineColor = 12
Case 2
iFillColor = 45
iLineColor = 10
Case 3
iFillColor = 43
iLineColor = 17
End Select

With myShape
.Fill.ForeColor.SchemeColor = iFillColor
.Line.ForeColor.SchemeColor = iLineColor
.Line.Weight = 1.5
.Fill.Transparency = 0.5
End With
End Select

Next
End Sub
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

Forum statistics

Threads
1,136,300
Messages
5,674,962
Members
419,536
Latest member
Mohammed Jaffer

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
Top