的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