Looping through selected presentations and fitting text to shapes

[inkarnation]

Hello forum,

I am a newbie both to these forums and to VBA, pleased to make your acquaintance.
Using a mix of inept abilities and code found online, I have been trying to create a Powerpoint macro that should:

1. Open a file dialog and allow you to select a number of PPT(X) files from a folder (or subfolders, through Search)
2. Process each file and fit all text to their corresponding shapes

I have gotten pretty far - the below seems to work when stepping through the macro, and the fit-text-to-shape bit works well in individual files.
But I must be doing something wrong as running the macro in full yields no results (although each files is saved).
I'm at my wits' end here, any help or advice would be much appreciated.

Thanks!

Sub FitTextToShapes()
    
Dim oSl As Slide
Dim oSh As Shape
Dim fd As FileDialog
Dim FileChosen As Integer
Dim vrtSelectedItem As Variant
Dim Current As Presentation


Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = True
fd.Filters.Add "PPT(X) files", "*.ppt*", 1
FileChosen = fd.Show
If FileChosen = -1 Then
    With fd
        For Each vrtSelectedItem In .SelectedItems
        Set Current = Presentations.Open(vrtSelectedItem)
        Current.Windows(1).Activate
            With ActivePresentation
                For Each oSl In .Slides
                    For Each oSh In oSl.Shapes
                        With oSh
                            If .HasTextFrame Then
                                If .TextFrame.HasText Then
                                    .TextFrame2.AutoSize = msoAutoSizeTextToFitShape
                                End If
                            End If
                        End With
                    Next
                Next
            End With
        ActivePresentation.Save
        ActivePresentation.Close
        Next
    End With
End If
MsgBox ("Done!")
End Sub

[John Wilson]

See if this does it:

Sub FitTextToShapes()
     
   Dim oSl As Slide
   Dim oSh As Shape
   Dim fd As FileDialog
   Dim strSelectedItem As String
   Dim otarget  As Presentation
   Dim L As Long
     
   Set fd = Application.FileDialog(msoFileDialogFilePicker)
  
        With fd
         fd.AllowMultiSelect = True
         fd.Filters.Add "PPT(X) files", "*.ppt*", 1
         If .Show = True Then
            For L = 1 To .SelectedItems.Count
            strSelectedItem = .SelectedItems(L)
                Set otarget = Presentations.Open(strSelectedItem)
                With otarget
                    For Each oSl In .Slides
                        For Each oSh In oSl.Shapes
                            With oSh
                                If .HasTextFrame Then
                                    If .TextFrame2.HasText Then
                                        .TextFrame2.AutoSize = msoAutoSizeTextToFitShape
                                        DoEvents
                                    End If
                                End If
                            End With
                        Next
                    Next
                End With
                otarget.Save
                otarget.Close
            Next L
            End If
        End With
    MsgBox ("Done!")
End Sub

[inkarnation]

Hi John and thank you for your reply!
I get the same results with your updated code as with my original. It works when stepped through or when running the msoAutoSizeTextToFitShape With block only, but running through the full macro opens and saves all selected presentations but does not fit text to shapes.
I'm not sure what I'm doing wrong.
I'm using Office 2013 and the macro is running from a separate PPTM.

[John Wilson]

I think I see what you mean

The code will change the SETTING for each shape but the text will not actually resize.

What happens if you delete or comment out the save and close lines and later save and close manually?

[inkarnation]

Wow, that worked! Thanks John!
Will marke this as solved but is there anyway to avoid having to save and close manually?
Worst case I assume I could write a separate macro for that but it would limit the amount of files I could process in one go.

[inkarnation]

Will marke this as solved but is there anyway to avoid having to save and close manually?

Macro works fab if I comment out the save/close lines but it really limits the use of the macro.
Is there any way to "trigger" the text fit and and still manage to save/close each file?
I tried replacing the text of each box and putting it back (commented out below) to see if this triggers the fit-to-shape action - doesn't change the outcome.

Sub FitTextToShape()     
    Dim oSl As Slide
    Dim oSh As Shape
    Dim fd As FileDialog
    Dim strSelectedItem As String
    Dim otarget  As Presentation
    Dim L As Long
    'Dim Tempo As String
         
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
     
    With fd
        fd.AllowMultiSelect = True
        fd.Filters.Add "PPT(X) files", "*.ppt*", 1
        If .Show = True Then
            For L = 1 To .SelectedItems.Count
                strSelectedItem = .SelectedItems(L)
                Set otarget = Presentations.Open(strSelectedItem)
                With otarget
                    For Each oSl In .Slides
                        For Each oSh In oSl.Shapes
                            With oSh
                                If .HasTextFrame Then
                                    If .TextFrame2.HasText Then
                                        .TextFrame2.AutoSize = msoAutoSizeTextToFitShape
                                        'Tempo = oSh.TextFrame.TextRange.Text
                                        '.TextFrame.TextRange = "Test"
                                        '.TextFrame.TextRange = Tempo
                                    End If
                                End If
                            End With
                        Next
                    Next
                End With
                'otarget.Save
                'otarget.Close
                'commenting out these lines makes the macro work but limits the amount of files it can be run on
            Next L
        End If
    End With
    MsgBox ("Done!")
End Sub

[John Wilson]

I tried all those things and added a 1 second delay before saving and none worked. I don't know why, sorry.

[inkarnation]

I tried all those things and added a 1 second delay before saving and none worked. I don't know why, sorry.

No worries John, thank you again for all your help!