Changing arc length in excel based on a cell value

Question

I want to dynamically change the Arc Length in Excel based on cell value. For example, if the cell value = 100%, the arch should become a complete circle. If the value = 0, it should disappear. I found below code that change the SIZE of the shape, but I don't know how to modify it to change the length.

Example:

Your help is much appreciated.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xAddress As String
    On Error Resume Next
    If Target.CountLarge = 1 Then
        xAddress = Target.Address(0, 0)
        If xAddress = "CT15" Then
            Call SizeCircle("Block Arc 63", Val(Target.Value))
        End If
    End If
End Sub

Sub SizeCircle(Name As String, Diameter)
    Dim xCenterX As Single
    Dim xCenterY As Single
    Dim xCircle As Shape
    Dim xDiameter As Single
    On Error GoTo ExitSub
    xDiameter = Diameter
    If xDiameter > 10 Then xDiameter = 10
    If xDiameter < 1 Then xDiameter = 1
    Set xCircle = ActiveSheet.Shapes(Name)
    With xCircle
        xCenterX = .Left + (.Width / 2)
        xCenterY = .Top + (.Height / 2)
        .Width = Application.CentimetersToPoints(xDiameter)
        .Height = Application.CentimetersToPoints(xDiameter)
        .Left = xCenterX - (.Width / 2)
        .Top = xCenterY - (.Height / 2)
    End With
ExitSub:
End Sub

Answer 1

You can use the Shapes.Adjustments property to adjust the "length" of the block arc.

Procedure AdjustArc will set the specified shape to the specified "% complete".

Procedure Demo will "animate" the progress in your shape. Make sure to change the Sheet name and Shape name as necessary before running the demo. Procedure Pause is only cosmetic for Demo.

Sub AdjustArc(arcShape As Shape, percent As Single)
'adjust the circumference of the arc or hides if 0%.
'Supply the percent as a fraction between 0 and 1. (50% = 0.5)

    With arcShape
        If percent <= 0 Then 'hide shape
            .Visible = False
            Exit Sub
        End If

        If percent > 1 Then percent = 1 'over 100%, make it 100%
        .Visible = True

        '0 = Full Circle, 359.9 = sliver, 360 = Full Circle
        .Adjustments.Item(1) = (1 - percent) * 359.9
    End With

End Sub

Sub demo() 'Run this one for demonstration
    Dim ws As Worksheet, sh As Shape, x As Single
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set sh = ws.Shapes("Block Arc 1")
    For x = 0 To 1 Step 0.005
        AdjustArc sh, x
        Pause 0.01
    Next x
End Sub

Sub Pause(seconds As Single) 'just for the demo
'pause for specified number of seconds
    Dim startTime As Single: startTime = Timer
    Do: DoEvents: Loop Until Timer >= startTime + seconds
End Sub

---

Short Version:

The line that changes the shape is:

ActiveSheet.Shapes("YourShapeName").Adjustments.Item(1) = x

...where x is a value > 0 and < 360.

---

Edit: Adapting to your code

Currently your example code calls SizeCircle when cell CT15 of the worksheet changes.

You can replace this line:

Call SizeCircle("Block Arc 63", Val(Target.Value))

...with this one:

AdjustArc ThisWorkbook.Sheets("Sheet1").Shapes("Block Arc 63"),Val(Target.Value) 

Just replace Sheet1 with the name of the worksheet which has the shape.

This is assuming the percentage is stored as an actual percentage (0 to 1) in CT15 ...how it's formatted doens't matter.

Your code and my SizeCircle procedure should be in the Worksheet module (since it has an on_change event) which you open by right-clicking the worksheet's tab and clicking View Code.

---

More Information:

• MSDN : Adjustments Object (Excel)
• Stack Overflow : Lots about Shapes (my answer)
• Code VBA : How to use Excel class Shape
• MSDN : Shape Object (Excel)