powerpoint vba 创建和保存幻灯片

Question

当我分别调用每个模块时，一切正常...但是当我从 MAIN 模块调用它们时，文本不会在保存的幻灯片上溢出时收缩。你能帮忙找到解决这个问题的方法吗

Sub MAIN()

Call Module1.CreateSlides
Call Module2.SaveSlides

End Sub

[模块 1]

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

[模块 2]

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

您提到了 "the text does not shrink on overflow on the saved slides"。你指的是什么文本？您的代码中没有设置以下属性的行，因此任何幻灯片上的对象都应遵循幻灯片母版（和关联的自定义布局）中这些对象的属性。

Sld.Shapes(x).TextFrame2.AutoSize = msoAutoSizeShapeToFitText

尝试使用上面的行根据需要明确设置适合选项。修改子：

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

这似乎是 PowerPoint 中的错误。我自己运行遇到了同样的问题。

如果你可以运行整个主批代码，然后单独运行另一个小模块到 "tidy up" 文本，你可以解决这个问题。

在主代码的某处，标记每个包含文本的形状（或者可能只是设置为溢出时收缩的形状）。例如，如果您在 oSh 中引用了形状：

oSh.Tags.Add "H", cStr(oSh.Height)
oSh.Tags.Add "W", cStr(oSh.Width)

现在形状被标记为它应该是的大小。当您的主代码将文本倒入其中时，大小将重置（不正确...这是错误）。

所以稍后，您运行单独编码

' 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

需要单独应用的修正模块

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

powerpoint vba 创建和保存幻灯片

powerpoint vba creating and saving slides

excel

powerpoint

vba