PowerPoint 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