powerpoint vba creating and saving slides - vba

Question

When I call each module separately everything works fine... but when I call them from the MAIN module the text does not shrink on overflow on the saved slides. Can you please help to find a way to fix this
Sub MAIN()
Call Module1.CreateSlides
Call Module2.SaveSlides
End Sub
   
[Module1]
Sub CreateSlides()
'Open the Excel workbook. Change the filename here.
Dim OWB As New Excel.Workbook
Set OWB = Excel.Application.Workbooks.Open("C:\B\Books\TXT.xlsx")
'Grab the first Worksheet in the Workbook
Dim WS As Excel.Worksheet
Set WS = OWB.Worksheets(1)
'Loop through each used row in Column A
For i = 1 To WS.Range("A65536").End(xlUp).Row
    'Copy the first slide and paste at the end of the presentation
    ActivePresentation.Slides(1).Copy
    ActivePresentation.Slides.Paste (ActivePresentation.Slides.Count + 1)
    'Change the text of the first text box on the slide.
    ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(1).TextFrame.TextRange.Text = WS.Cells(i, 1).Value
    ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(2).TextFrame.TextRange.Text = WS.Cells(i, 2).Value
    ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(3).TextFrame.TextRange.Text = WS.Cells(i, 3).Value
 Next
'Close Excel
ActiveWorkbook.Close
'Delete presentation
ActivePresentation.Slides(1).Delete
End Sub
[Module2]
Sub SaveSlides ()
'Save slides as png
Dim sImagePath As String
Dim sImageName As String
Dim oSlide As Slide '* Slide Object
On Error GoTo Err_ImageSave
sImagePath = "C:\"
For Each oSlide In ActivePresentation.Slides
sImageName = oSlide.SlideNumber & ".png"
oSlide.Export sImagePath & sImageName, "PNG"
Next oSlide
Err_ImageSave:
If Err <> 0 Then
MsgBox Err.Description
End If
'Delete all slides
Dim Pre As Presentation
Set Pre = ActivePresentation
Dim x As Long
For x = Pre.Slides.Count To 1 Step -1
    Pre.Slides(x).Delete
Next x
'Add New slide
Set pptLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(1)
Set Sld = ActivePresentation.Slides.AddSlide(1, pptLayout)
Sld.Design = ActivePresentation.Designs(1)
End Sub

Answer 1

You mentioned "the text does not shrink on overflow on the saved slides". What text are you referring to? There are no lines that are setting the following property in your code so any on-slide objects should be following the properties of those objects in your Slide Master (and associated Custom Layouts).
Sld.Shapes(x).TextFrame2.AutoSize = msoAutoSizeShapeToFitText
Try using the above line to explicitly set the fit option as required. Modified sub:
Option Explicit
Sub CreateSlides()
'Open the Excel workbook. Change the filename here.
Dim OWB As New Excel.Workbook
Set OWB = Excel.Application.Workbooks.Open("C:\B\Books\TXT.xlsx")
Dim i As Long
'Grab the first Worksheet in the Workbook
Dim WS As Excel.Worksheet
Set WS = OWB.Worksheets(1)
'Loop through each used row in Column A
For i = 1 To WS.Range("A65536").End(xlUp).Row
With ActivePresentation
'Copy the first slide and paste at the end of the presentation
.Slides(1).Copy
.Slides.Paste (.Slides.Count + 1)
'Change the text of the first text box on the slide.
With .Slides(.Slides.Count).Shapes(1).TextFrame2
.AutoSize = msoAutoSizeShapeToFitText
.WordWrap = msoTrue
.TextRange.Text = WS.Cells(i, 1).Value
End With
With .Slides(.Slides.Count).Shapes(2).TextFrame2
.AutoSize = msoAutoSizeShapeToFitText
.WordWrap = msoTrue
.TextRange.Text = WS.Cells(i, 2).Value
End With
With .Slides(.Slides.Count).Shapes(3).TextFrame2
.AutoSize = msoAutoSizeShapeToFitText
.WordWrap = msoTrue
.TextRange.Text = WS.Cells(i, 3).Value
End With
End With
Next
'Close Excel
ActiveWorkbook.Close
'Delete presentation
ActivePresentation.Slides(1).Delete
End Sub

Answer 2

This appears to be a bug in PowerPoint. I've run into the same problem myself.
If you can run the whole main batch of code, then separately run another small module to "tidy up" the text, you can fix this.
Somewhere in the main code, tag each shape that holds text (or perhaps just the ones set to shrink on overflow). For example, if you had a reference to the shape in oSh:
oSh.Tags.Add "H", cStr(oSh.Height)
oSh.Tags.Add "W", cStr(oSh.Width)
Now the shape is tagged with the size it SHOULD be. When your main code pours text into it, the size will reset (incorrectly... there's the bug).
So later, separately, you run code that
' Looks at each shape on each slide and
' if it's tagged, reset the size to the
' size indicated by the tags:
If Len(oSh.Tags("H")) > 0 Then
oSh.Height = cSng(oSh.Tags("H")
oSh.Width = cSng(oSh.Tags("W")
End if

Answer 3

Fixup module to be applied separately
Sub FixUp()
Dim Obj1 As Object
Set Obj1 = CreateObject("powerpoint.application")
Obj1.Presentations.Open FileName:="C:\B\name.pptm"
Dim pptSlide As Slide
Dim pptShape as Shape
'Set pptSlide = ActivePresentation.Slides(1)
For Each pptSlide in ActivePresentation.Slides
'With pptSlide.Shapes(1)
For Each pptShape in pptSlide.Shapes
With pptShape
If .TextFrame2.TextRange.Characters.Count > 1 Then
.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End If
End With ' pptShape
Next ' pptShape
End With
Next ' Slide
End Sub