[SOLVED] Rounded Corner Should be constant in Powerpoint VBA script

Rounded Corner Should be constant in Powerpoint VBA script

I was working on below given script to convert all the corners in rounded corners, but the rounded corners are not giving same values for all shapes.

I have worked on below scripts

Sub RoundedCorner5()


    Dim oShape As Shape
Dim sngRadius As Single ' Radius size in points

sngRadius = 0.05
For Each oShape In ActiveWindow.Selection.ShapeRange

    With oShape
         oShape.AutoShapeType = msoShapeRoundedRectangle
         oShape.TextFrame.WordWrap = msoFalse
         oShape.TextEffect.Alignment = msoTextEffectAlignmentCentered
        .Adjustments(1) = sngRadius
    End With
Next
Set oShape = Nothing

End Sub

Suppose if I have one small rectangle and one big rectangle the the rounded corner values come different for both shapes

Solution

By default, round corners are proportional to the shape size. Here is Microsoft's page about adjustments, please note that the units are not points: Adjustments object (PowerPoint)

This code should get you pretty close, change RadiusFactor to get the corner size you prefer:

Sub RoundedCorner5()
  Dim oShape As Shape
  Dim RadiusFactor As Single
  RadiusFactor = 50
  For Each oShape In ActiveWindow.Selection.ShapeRange
    With oShape
      .AutoShapeType = msoShapeRoundedRectangle
      .Adjustments(1) = (1 / (oShape.Height + oShape.Width)) * RadiusFactor
      .TextFrame.WordWrap = msoFalse
      .TextEffect.Alignment = msoTextEffectAlignmentCentered
    End With
  Next
End Sub