<

How to set and determine the rounding in AutoShapes with VBA

Published on
12,901 Points
6,801 Views
1 Endorsement
Last Modified:
Approved
MS-Office allows to insert various shapes into  your documents (Word, Excel, Powerpoint, etc.), some of them have rounded angles, like  

msoShapeRoundedRectangle,
msoShapeRound2DiagRectangle,
msoShapeRound2SameRectangle,
and others.

to adjust the rounding, you have normally to use the yellow diamond adjustment handle.

In VBA, you can use Adjustments. Item(1), mostly Item 1, sometimes Item 2 as well

For example in Excel:
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

Open in new window

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.

Example 1In this example, the adjustment measure is 0.5, which is half the height of the shape.

This adjustment method ensures that the rounding remains in proportion to the shape, when it is resized, but sometimes, we would like to have a determined rounding for a series of different-sized shapes.

Then you have to calculate the radius of the rounding to be able to reproduce it.

Like in this example :
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

Open in new window



Of course if the radius size is greater than half the side, then it will only round it until half-circle (min( Adjustments(1), 0.5)

You will see that due to rounding problems (again!) , that after having set the radius on the shape, if  you perform GetRadius, you will not have the same numbers, but the difference is really insubstantial.

In addition to this , we can now calculate the area of the shapes:

For example the rounded rectangle, the formula would be (height * width of the rectangle) less  4 * (radius^2) plus (pi * (radius^2))

simplified to (h * w) - ((4 - pi) * (r^2))

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

Open in new window

1
Comment
Author:Rgonzo1971
0 Comments

Featured Post

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

Join & Write a Comment

In this video you will find out how to export Office 365 mailboxes using the built in eDiscovery tool. Bear in mind that although this method might be useful in some cases, using PST files as Office 365 backup is troublesome in a long run (more on t…
This lesson discusses how to use a Mainform + Subforms in Microsoft Access to find and enter data for payments on orders. The sample data comes from a custom shop that builds and sells movable storage structures that are delivered to your property. …

Keep in touch with Experts Exchange

Tech news and trends delivered to your inbox every month