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:

Open a file dialog and allow you to select a number of PPT(X) files from a folder (or subfolders, through Search)
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!