根据单元格值更改excel中的弧长

Question

我想根据单元格值动态更改 Excel 中的弧长。 例如，如果单元格值 = 100%，则拱门应成为一个完整的圆。如果值 = 0，它应该消失。 我发现下面的代码改变了形状的大小，但我不知道如何修改它来改变长度。

示例：

非常感谢您的帮助。

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

您可以使用Shapes.Adjustments属性来调整块弧的“长度”。

Procedure AdjustArc 会将指定的形状设置为指定的“% complete”。

Procedure Demo 将“动画化”您的形状进度。确保在运行演示之前根据需要更改工作表名称和形状名称。过程Pause 只是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

---

短版：

改变形状的线是：

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

...其中x 是一个值> 0 and < 360。

---

编辑：适应你的代码

当前，当工作表的单元格 CT15 发生更改时，您的示例代码会调用 SizeCircle。

你可以替换这一行：

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

...用这个：

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

只需将Sheet1 替换为具有该形状的工作表的名称即可。

这是假设百分比存储为CT15 中的实际百分比（0 到 1）...如何格式化并不重要。

您的代码和我的SizeCircle 过程应该位于工作表模块（因为它有一个on_change 事件），您可以通过右键单击工作表的选项卡并单击View Code 打开该模块。

---

更多信息：

• MSDN : Adjustments Object (Excel)
• 堆栈溢出：Lots about Shapes (my answer)
• 代码 VBA：How to use Excel class Shape
• MSDN：Shape Object (Excel)