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

2023-12-12

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

Example:

非常感谢您的帮助。

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

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

程序AdjustArc将指定的形状设置为指定的“％完全的".

程序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.

Edit:适应您的代码

目前您的示例代码调用SizeCircle当工作表的单元格 CT15 发生变化时。

您可以替换这一行：

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

...用这个：

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

只需更换Sheet1以及具有该形状的工作表的名称。

这是假设百分比是stored作为实际百分比（0 到 1）CT15...它的格式如何并不重要。

你的代码和我的SizeCircle程序应在工作表模块（因为它有一个 on_change 事件）您可以通过右键单击工作表的选项卡并单击View Code.

vba

Excel