VBA shading area under a line.

BGG

New Member
Joined
Jan 13, 2010
Messages
15
Hi all

I use a macro to shade a area under a line in a graph:

Dim myCht As Chart
Dim mySrs As Series
Dim Npts As Integer, Ipts As Integer
Dim myBuilder As FreeformBuilder
Dim myShape As Shape
Dim Xnode As Double, Ynode As Double
Dim Xmin As Double, Xmax As Double
Dim Ymin As Double, Ymax As Double
Dim Xleft As Double, Ytop As Double
Dim Xwidth As Double, Yheight As Double

Set myCht = ActiveChart
Xleft = myCht.PlotArea.InsideLeft
Xwidth = myCht.PlotArea.InsideWidth
Ytop = myCht.PlotArea.InsideTop
Yheight = myCht.PlotArea.InsideHeight
Xmin = myCht.Axes(1).MinimumScale
Xmax = myCht.Axes(1).MaximumScale
Ymin = myCht.Axes(2).MinimumScale
Ymax = myCht.Axes(2).MaximumScale

Set mySrs = myCht.SeriesCollection(1)
Npts = mySrs.Points.Count

' first point
Xnode = Xleft + (mySrs.XValues(1) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
Set myBuilder = myCht.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)

' remaining points
For Ipts = 1 To Npts
Xnode = Xleft + (mySrs.XValues(Ipts) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + (Ymax - mySrs.Values(Ipts)) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next

Xnode = Xleft + (mySrs.XValues(Npts) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Xnode = Xleft + (mySrs.XValues(1) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + Yheight
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode

Set myShape = myBuilder.ConvertToShape

With myShape ' kleur instellen
.Fill.ForeColor.SchemeColor = 2
.Fill.Transparency = 0.8
.Line.Visible = False
End With
End Sub

I want to adjust this so that it shades area''s under or above all the lines in that graph lines.

Preferreble shading above the line/under/no shading depends on a number (reference) in a cell. So that I can make a checkbox for the user. And the macro loops until it has executed all the preset wishes for all the lines that are present.

btw, the scrip I use for shading abice the line is the following. The part I marked red is how I tried to make it loop for or the lines. It does repeat the shading for each line, but the are all in the same place, because the location is not adjusted to match the area under (or above) the second line. And also there is no choise between above/under or no shading.

Can anybody help me adjust these scripts?

Bas

Dim myCht As Chart
Dim mySrs As Series, Isrs As Integer
Dim Npts As Integer, Ipts As Integer
Dim myBuilder As FreeformBuilder
Dim myShape As Shape
Dim Xnode As Double, Ynode As Double
Dim Xmin As Double, Xmax As Double
Dim Ymin As Double, Ymax As Double
Dim Xleft As Double, Ytop As Double
Dim Xwidth As Double, Yheight As Double

Set myCht = ActiveChart
Xleft = myCht.PlotArea.InsideLeft
Xwidth = myCht.PlotArea.InsideWidth
Ytop = myCht.PlotArea.InsideTop
Yheight = myCht.PlotArea.InsideHeight
Xmin = myCht.Axes(1).MinimumScale
Xmax = myCht.Axes(1).MaximumScale
Ymin = myCht.Axes(2).MinimumScale
Ymax = myCht.Axes(2).MaximumScale

For Isrs = 1 To myCht.SeriesCollection.Count

Set mySrs = myCht.SeriesCollection(1)
Npts = mySrs.Points.Count

' first point
Xnode = Xleft
Ynode = Ytop + (Ymax - mySrs.Values(1)) * Yheight / (Ymax - Ymin)
Set myBuilder = myCht.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)

' remaining points
For Ipts = 1 To Npts
Xnode = Xleft + (mySrs.XValues(Ipts) - Xmin) * Xwidth / (Xmax - Xmin)
Ynode = Ytop + (Ymax - mySrs.Values(Ipts)) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next

Xnode = Xleft
Ynode = Ytop + (Ymax - mySrs.Values(1)) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Xnode = Xleft
Ynode = Ytop + (Ymax - mySrs.Values(1)) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode

Set myShape = myBuilder.ConvertToShape

With myShape ' kleur instellen
.Fill.ForeColor.SchemeColor = 2
.Fill.Transparency = 0.8
.Line.Visible = False

End With
Next
End Sub
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

Forum statistics

Threads
1,213,534
Messages
6,114,188
Members
448,554
Latest member
Gleisner2

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