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属性来调整块弧的“长度”。

过程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。

编辑：适应您的代码

当前，当工作表的单元格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事件），您可以通过右键单击工作表的标签并单击{{1} }。

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

1 个答案:

短版：

编辑：适应您的代码

更多信息：