Resize text of selected shapes

[juanbolas]

Hello

I'm trying to resize the text of the selected shapes in the current slide.


Sub ResizeFont(Optional FontSize As Integer)
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
.TextFrame.textRange.Font.Size = 8
End If
End With
End Sub

The (Optional FontSize As Integer) is to be able to pass different font sizes from a set of buttons with the desired font side I've created on a custom ribbon.

The code runs, I get no error, but it does nothing.

Thanks in advance for your help.

[John Wilson]

With ActiveWindow.Selection If .Type = ppSelectionShapes Then
.ShapeRange.TextFrame.TextRange.Font.Size = 8
End If
End With

[juanbolas]

Works like a charm! Thanks John!

[juanbolas]

I added some error checking and tried to polish up the code a bit


Sub test()
ResizeText 10
End Sub


Sub ResizeText(Optional shFontSize As Integer)
Dim oShape
On Error GoTo CheckErrors
With ActiveWindow.Selection.ShapeRange
If .Count = 0 Then
MsgBox "You need to select a shape first"
Exit Sub
End If
End With
For Each oShape In ActiveWindow.Selection.ShapeRange
oShape.TextFrame.textRange.Font.Size = shFontSize
Next
Exit Sub
CheckErrors: MsgBox Err.Description
End Sub


But now I realize it doesn't work with grouped shapes. :crying:

Any ideas on how I can proceed?

Thanks in advance!

[John Wilson]

Try this

PS always test that the shape has a textframe as it might be e.g. a picture and the code will fail


Sub test()
ResizeText 10
End Sub


Sub ResizeText(Optional shFontSize As Integer)

Dim oShape As Shape
Dim L As Long
On Error GoTo CheckErrors
With ActiveWindow.Selection.ShapeRange
If .Count = 0 Then
MsgBox "You need to select a shape first"
Exit Sub
End If
End With
For Each oShape In ActiveWindow.Selection.ShapeRange
If oShape.Type = msoGroup Then
For L = 1 To oShape.GroupItems.Count
If oShape.GroupItems(L).HasTextFrame Then oShape.GroupItems(L).TextFrame.TextRange.Font.Size = shFontSize
Next
Else
If oShape.HasTextFrame Then oShape.TextFrame.TextRange.Font.Size = shFontSize
End If
Next
Exit Sub
CheckErrors: MsgBox Err.Description
End Sub

[juanbolas]

Idol! :bow::bow::bow:
Thank you!