[英]powerpoint vba creating and saving slides
當我分別調用每個模塊時,一切正常...但是當我從MAIN模塊中調用它們時,文本不會在保存的幻燈片溢出時縮小。 您能幫忙找到解決此問題的方法嗎
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
您提到“文本不會在已保存的幻燈片上溢出時縮小”。 您指的是什么文字? 沒有任何行在代碼中設置以下屬性,因此任何幻燈片上的對象都應跟隨幻燈片母版(以及關聯的自定義布局)中這些對象的屬性。
Sld.Shapes(x).TextFrame2.AutoSize = msoAutoSizeShapeToFitText
嘗試使用上面的行根據需要顯式設置fit選項。 修改后的子:
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
這似乎是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
修復模塊要單獨應用
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.