AutoShape Charting

With some effort it is possible to draw Shapes and AutoShapes to act like charts.

If you’ve never played with AutoShapes before, I encourage you to look. I’ve wasted hours on it… well… that and playing Tetris.
Make sure the Drawing toolbar is visible: From the View menu select Toolbars, Drawing should be ticked.
It usually docks itself to the bottom of the screen.

AutoShapes have differences from regular Shapes. One difference is that you can set Transparency on them.
In this example I’ve configured two plain “Can” AutoShapes (From the Basic Shapes category).
The can in the foreground is transparent and gives that “coffee in a cup” look.

You’ll notice that I’ve attached a scrollbar. That’s just for fun.
If you want the scrollbar, run the Setup procedure to set it all up. Otherwise just run SetupContainer.

Put this code in a standard code module:

Const cLeft = 50, cTop = 20, cWidth = 118, cHeight = 120
Const cDifference = 6, cRadialHeight = 8
Const cContainerName = “MyContainer”
Const cContentName = “MyContent”
Const cContainerColor = &H808080    ‘RGB(128, 128, 128)
Const cContentColor = &H80          ‘RGB(128, 0, 0)
Const cContentFormula = “=A1”
Sub Setup()
    Dim ole As OLEObject
    ‘Adds a Scrollbar for fun
   Set ole = ActiveSheet.OLEObjects.Add(ClassType:=“Forms.ScrollBar.1”, Left:=cLeft – 20, Top:=cTop, Width:=16, Height:=cHeight)
    ole.Object.Min = 100
    ole.Object.Max = 0
    ole.LinkedCell = cContentFormula
End Sub
Sub SetupContainer()
    ‘Creates the Content first
   With ActiveSheet.Shapes.AddShape(msoShapeCan, cLeft + cDifference, cTop + cDifference, cWidth – cDifference * 2, 1)
        .Name = cContentName
        .Adjustments(1) = cRadialHeight * 2 / cHeight
        .Fill.ForeColor.RGB = cContentColor
    End With
    ‘Creates the Container last (for transparency)
   With ActiveSheet.Shapes.AddShape(msoShapeCan, cLeft, cTop, cWidth, cHeight)
        .Name = cContainerName
        .Adjustments(1) = cRadialHeight * 2 / cHeight
        .Fill.ForeColor.RGB = cContainerColor
        .Fill.Transparency = 0.75
        Selection.Formula = cContentFormula
        .TextFrame.Characters.Text = “”
        .TextFrame.Characters.Font.Size = 20
        .TextFrame.HorizontalAlignment = xlCenter
        .TextFrame.VerticalAlignment = xlCenter
    End With
    NewContentHeight Evaluate(cContentFormula)
End Sub
Sub NewContentHeight(sngHeight As Single)
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes(cContainerName)
    With ActiveSheet.Shapes(cContentName)
        .Top = shp.Top + shp.Height – sngHeight – cDifference
        .Height = sngHeight
        If sngHeight = 0 Then
            .Adjustments(1) = 0
            .Adjustments(1) = cRadialHeight * 2 / sngHeight
        End If
    End With
End Sub

Put this code in the worksheet code module:

Private Sub ScrollBar1_Change()
    NewContentHeight Range(“A1”).Value
End Sub
Private Sub ScrollBar1_Scroll()
    NewContentHeight Range(“A1”).Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range(“A1”)) Is Nothing Then NewContentHeight Range(“A1”).Value
End Sub
Posted in Uncategorized

3 thoughts on “AutoShape Charting

  1. Very nice, my colleaques will be very impressed.
    I added a shadow to the content and it looks even more 3D, especially when i scroll the values up/down.

  2. Very nice, Rob.

    I’ve made drill-down map charts using similar methods.

    Also used DrawingObjects to drive PivotTables. Users like interacting with pictures.

  3. Hi, Joseph

    I wonder if it were possible to send some examples you announced ( pivot tables linked with drawing objects)? It sounds quite interesting to me.

    Thank you in advance

    Jiri Cihar

Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.