Sub GetShapeRounding()
Dim myDocument As Worksheet
Dim oShape As Shape
Set myDocument = Worksheets(1)
Set oShape = myDocument.Shapes(1)
Debug.Print oShape.Adjustments(1)
Set oShape = Nothing
End Sub
Sub SetShapeRounding()
Dim myDocument As Worksheet
Dim oShape As Shape
Set myDocument = Worksheets(1)
Set oShape = myDocument.Shapes(1)
oShape.Adjustments(1) = 0.3
Set oShape = Nothing
End Sub
According to the microsoft online help (http://msdn.microsoft.com/en-us/library/office/bb265480(v=office.12).aspx), it is an adjustment value in proportion to the width of the shape: 1.0 corresponds to the width of the shape. The maximum value is 0.5, or half way across the shape. But this is not quite true, because the maximum rounding can only be made on the shorter pair of sides, creating a half-circle. 0 (zero) sets a no rounding to the shape.
Sub GetShapeRoundingRadius()
Dim myDocument As Worksheet
Dim oShape As Shape
Dim sngRadius As Single ' Radius size in points
Set myDocument = Worksheets(1)
Set oShape = myDocument.Shapes(1)
With oShape
If .Width < .Height Then
sngRadius = .Width * .Adjustments(1)
Else ' .Width >= .Height
sngRadius = .Height * .Adjustments(1)
End If
End With
Debug.Print sngRadius
Set oShape = Nothing
End Sub
Sub SetShapeRoundingRadius()
Dim myDocument As Worksheet
Dim oShape As Shape
Dim sngRadius As Single ' Radius size in points
Set myDocument = Worksheets(1)
Set oShape = myDocument.Shapes(1)
sngRadius = 40
With oShape
If .Width < .Height Then
.Adjustments(1) = sngRadius / .Width
Else ' .Width >= .Height
.Adjustments(1) = sngRadius / .Height
End If
End With
Set oShape = Nothing
End Sub
Sub GetShapeArea()
Dim myDocument As Worksheet
Dim oShape As Shape
Dim sngRadius As Single ' Radius size in points
sngPi = 3.141593
Set myDocument = Worksheets(1)
Set oShape = myDocument.Shapes(1)
With oShape
If .Width < .Height Then
sngRadius = .Width * .Adjustments(1)
Else ' .Width >= .Height
sngRadius = .Height * .Adjustments(1)
End If
sngArea = (.Width * .Height) - ((4 - sngPi) * (sngRadius * sngRadius))
End With
Debug.Print sngArea
Set oShape = Nothing
End Sub
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (0)