的PowerPoint VBA创建和保存幻灯片

Question

当我打电话每个模块单独一切正常......但是当我把他们从主要模块中的文本不上保存的幻灯片溢出收缩。能否请你帮忙找到一种方法来解决这个

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 

[单词数]

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

Fixup时模块，分别应用于

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 

Answer 2

您提到“在保存的幻灯片上溢出的文本不会缩小”。你指的是什么文字？没有行在您的代码中设置以下属性，因此任何幻灯片对象都应该遵循幻灯片母版（以及相关的自定义布局）中这些对象的属性。

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 3

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

如果你可以运行整个主批次的代码，然后单独运行另一个小模块来“整理”文本，你可以修复这个问题。

在主代码的某处，标记每个保存文本的形状（或者可能只是设置为在溢出时缩小的形状）。例如，如果您参考了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