PowerPoint VBA (Macros) 教程

奇思

另存为宏功能演示文稿

带有VBA代码的演示文稿应该 "保存为 "PowerPoint支持宏的演示文稿(*.pptm)

启用功能区中的 "开发人员 "选项卡

在创建VBA代码之前，你应该在Ribbon中启用 "开发者 "选项卡。要做到这一点，请选择 "文件 -> 选项"，然后点击 "自定义功能区"，并在右侧窗格中勾选 "开发人员 "选项卡旁边的方框。

创建PowerPoint宏

这是一个简单的PowerPoint VBA宏的例子。

Sub SavePresentationAsPDF()
 Dim pptName As String
 Dim PDFName As String
 
 ' Save PowerPoint as PDF
 pptName = ActivePresentation.FullName
 ' Replace PowerPoint file extension in the name to PDF
 PDFName = Left(pptName, InStr(pptName, ".")) & "pdf"
 ActivePresentation.ExportAsFixedFormat PDFName, 2 ' ppFixedFormatTypePDF = 2
 
End Sub

它将活动的演示文稿保存为PDF格式。每一行代码都会做以下工作。

为PowerPoint名称和PDF名称创建变量
将活动的演示文稿名称分配给pptName变量。
创建完整的PDF名称
将演示文稿保存为PDF格式

PowerPoint应用

当VBA代码在PowerPoint演示文稿中运行时，PowerPoint应用程序是默认的应用程序，无需显式引用即可操作。创建一个新的演示文稿

要创建一个演示文稿，请使用PowerPoint应用程序的添加方法。

Application.Presentations.Add
' or without explicit reference
Presentations.Add

打开一个新的演示文稿

要打开一个新的、空白的演示文稿，请使用Application.Presentations集合的Add方法。

Presentations.Add

打开一个现有的演示文稿

要打开您已经创建的演示文稿，请使用Application.Presentations集合的Open方法来打开。

Presentations.Open ("My Presentation.pptx")

上面的代码假设演示文稿与包含该代码的PowerPoint演示文稿在同一目录下。

打开并分配到一个变量

你应该把你打开的演示文稿分配给一个变量，这样你就可以根据你的要求来操作它。

Dim ppt As Presentation
Set ppt = Presentations.Open("My Presentation.pptx")

引用活动演示文稿

当VBA代码被执行时，使用ActivePrentation来操作GUI中的当前的演示文稿对象。

' 将ActivePresentation的名称打印到即时窗口中。
Debug.Print ActivePresentation.Name

保存当前演示文稿

下面的语句将保存活动演示文稿，如果它之前已经保存了，那么下面的语句将保存活动演示文稿。如果还没有保存过，则会出现 "另存为 "对话框。

ActivePresentation.Save

关闭当前演示文稿

以下语句将关闭当前活动的演示文稿，即使在上次编辑后没有保存。

ActivePresentation.Close

有用的参考资料

将现有演示文稿（按名称）分配给变量

Dim myPresentationByName As Presentation
Set myPresentationByName = Application.Presentations("My Presentation")

将当前活动幻灯片分配给变量

Dim currentSlide As Slide
Set currentSlide = Application.ActiveWindow.View.Slide

将幻灯片按索引分配到变量

Dim mySlide As Slide
Set mySlide = ActivePresentation.Slides(11)

统计幻灯片数量

Dim slideCount As Long
slideCount = ActivePresentation.Slides.Count

获取当前幻灯片的幻灯片序号

Dim currentSlideIndex As Slide
currentSlideIndex = Application.ActiveWindow.View.Slide.SlideIndex

在幻灯片末尾添加空白幻灯片

Dim slideCount As Long
Dim newSlide as Slide
 
slideCount = ActivePresentation.Slides.Count
Set newSlide = ActivePresentation.Slides.Add(slideCount + 1, 12)
' or as ppLayoutBlank = 12
Set newSlide = ActivePresentation.Slides.Add(slideCount + 1, ppLayoutBlank)

在当前幻灯片后添加一个幻灯片

Dim newSlide As Slide
Dim currentSlideIndex as Integer
 
currentSlideIndex = Application.ActiveWindow.View.Slide.SlideIndex
Set newSlide = ActivePresentation.Slides.Add(currentSlideIndex, ppLayoutBlank)

删除一张幻灯片

Dim currentSlideIndex as Integer
 
currentSlideIndex = Application.ActiveWindow.View.Slide.SlideIndex
ActivePresentation.Slides(currentSlideIndex).Delete

转到特定的幻灯片

' This will take you to slide number 4
Application.ActiveWindow.View.GotoSlide (4)

移动幻灯片

您可以将幻灯片从原来的位置移动到新的位置。

' Move from slide 3 to first slide
Dim oldPosition as integer, dim newPosition as integer
 
oldPosition = 3
newPosition = 1
ActivePresentation.Slides(oldPosition).MoveTo toPos:=newPosition

遍历所有幻灯片

你可以在每张幻灯片上做一些事情，也可以翻阅所有的幻灯片，找到几张幻灯片，用代码做一些事情。

Dim mySlide as Slide
 
For Each mySlide In ActivePresentation.Slides
 ' Do something with the current slide referred to in variable 'mySlide'
 ' Debug.Print mySlide.Name
Next Slide

遍历当前幻灯片的所有形状对象

可以通过使用 "形状 "来实现PowerPoint的威力。下面的代码将遍历当前幻灯片上的所有形状，这样你就可以按照你的要求来操作它们。

Dim currentSlide as Slide
Dim shp as Shape
 
Set currentSlide = Application.ActiveWindow.View.Slide
For Each shp In currentSlide.Shapes
 ' Do something with the current shape referred to in variable 'shp'
 ' For example print the name of the shape in the Immediate Window
 Debug.Print shp.Name
Next shp

遍历所有幻灯片中的所有形状

你可以通过添加一个循环来遍历所有幻灯片中的所有形状。

Dim currentSlide as Slide
Dim shp as Shape
 
For Each currentSlide In ActivePresentation.Slides
 For Each shp In currentSlide.Shapes
 ' Do something with the current shape referred to in variable 'shp'
 Debug.Print shp.Name
 Next shp
Next currentSlide

遍历活动幻灯片的所有文本框

文本框是PowerPoint演示文稿中最常用的形状。你可以通过添加一个 "形状类型 "的复选框，在所有的文本框中循环使用。文本框的形状类型定义为VBA常数msoTextBox（常数值为17）。

Dim currentSlide as Slide
Dim shp as Shape
 
Set currentSlide = Application.ActiveWindow.View.Slide
For Each shp In currentSlide.Shapes
 ' Check if the shape type is msoTextBox 
 If shp.Type = 17 Then ' msoTextBox = 17
 'Print the text in the TextBox
 Debug.Print shp.TextFrame2.TextRange.Text
 End If
Next shp

遍历所有幻灯片中的所有文本框

同样，你可以通过添加一个循环来遍历所有的幻灯片。

1Dim currentSlide as Slide Dim shp as Shape
 
For Each currentSlide In ActivePresentation.Slides
 For Each shp In currentSlide.Shapes
 ' Check if the shape type is msoTextBox 
 If shp.Type = 17 Then ' msoTextBox = 17
 ' Do something with the TextBox referred to in variable 'shp'
 Debug.Print shp.TextFrame2.TextRange.Text
 End If
 Next shp
Next currentSlide

将选定的幻灯片复制到新的PPT演示文稿

要将某些幻灯片复制到新的演示文稿中，首先在现有的演示文稿中选择需要的幻灯片，然后运行下面的代码。

Dim currentPresentation as Presentation
Dim currentSlide as Slide
Dim newPresentation as Presentation
 
' Save reference to current presentation
Set currentPresentation = Application.ActivePresentation
 
' Save reference to current slide
Set currentSlide = Application.ActiveWindow.View.Slide
 
' Add new Presentation and save to a reference
Set NewPresentation = Application.Presentations.Add
 
' Copy selected slides
Selection.Copy
 
' Paste it in new Presentation
NewPresentation.Slides.Paste

将当前幻灯片复制到当前演示文稿的末尾

' Copy current slide
Application.ActiveWindow.View.Slide.Copy
 
' Paste at the end
ActivePresentation.Slides.Paste

有用的PowerPoint宏示例

这里有一些有用的宏示例，展示如何做任务。这些例子也将展示上述概念。

在幻灯片放映过程中切换当前幻灯片

Sub ChangeSlideDuringSlideShow()
 Dim SlideIndex As Integer
 Dim SlideIndexPrevious As Integer
 
 '  Change Current slide to selected slide 4 during slide show
 SlideIndex = 4
 ' Index of the current slide show window is 1 in the SlideShowWindows collection
 SlideIndexPrevious = SlideShowWindows(1).View.CurrentShowPosition
 SlideShowWindows(1).View.GotoSlide SlideIndex
 
End Sub

更改所有文本框中所有幻灯片上的字体

Sub ChangeFontOnAllSlides()
 Dim mySlide As slide
 Dim shp As Shape
 
 ' Change Font Size on all Slides
 For Each mySlide In ActivePresentation.Slides
 For Each shp In mySlide.Shapes
 If shp.Type = 17 Then ' msoTextBox = 17
 ' Change Fontsize to 24
 shp.TextFrame.TextRange.Font.Size = 24
 End If
 Next shp
 Next mySlide
 
End Sub

将所有文本框中的大小写从大写改为正常值

Sub ChangeCaseFromUppertoNormal()
 Dim mySlide As slide
 Dim shp As Shape
 
 ' Change From Upper Case to Normal Case for all slides
 For Each mySlide In ActivePresentation.Slides
 For Each shp In mySlide.Shapes
 If shp.Type = 17 Then ' msoTextBox = 17
 ' Change Upper Case to Normal Case
 shp.TextFrame2.TextRange.Font.Allcaps = False
 End If
 Next shp
 Next mySlide
 
End Sub

在所有文本框的大小写在大写和正常值之间切换

Sub ToggleCaseBetweenUpperAndNormal()
 Dim mySlide As slide
 Dim shp As Shape
 
 '  Toggle between Upper Case and Normal Case for all slides
 For Each mySlide In ActivePresentation.Slides
 For Each shp In mySlide.Shapes
 If shp.Type = 17 Then ' msoTextBox = 17
 ' Toggle between Upper Case and Normal Case
 shp.TextFrame2.TextRange.Font.Allcaps = _
 Not shp.TextFrame2.TextRange.Font.Allcaps
 End If
 Next shp
 Next mySlide
 
End Sub

移除下划线

在字体设计中，下伸部分是指字母的基线以下的部分。在大多数字体中，下划线是为小写字母保留的，如g、j、q、p、y，有时还有f。

当你在给文字加下划线时，在下伸部分以下的文字看起来并不美观。下面是在整个演示文稿中删除g、j、p、q、y等所有此类字符下划线的代码。

Sub RemoveUnderlineFromDescenders()
 Dim mySlide As slide
 Dim shp As Shape
 Dim descenders_list As String
 Dim phrase As String
 Dim x As Long
 
 ' Remove underlines from Descenders
 descenders_list = "gjpqy"
 For Each mySlide In ActivePresentation.Slides
 For Each shp In mySlide.Shapes
 If shp.Type = 17 Then ' msoTextBox = 17
 ' Remove underline from letters "gjpqy"
 With shp.TextFrame.TextRange
 phrase = .Text
 For x = 1 To Len(.Text)
 If InStr(descenders_list, Mid$(phrase, x, 1)) > 0 Then
 .Characters(x, 1).Font.Underline = False
 End If
 Next x
 End With
 End If
 Next shp
 Next mySlide
 
End Sub

从所有幻灯片中删除动画

使用下面的代码来删除演示文稿中设置的所有动画。

Sub RemoveAnimationsFromAllSlides()
 Dim mySlide As slide
 Dim i As Long
 
 For Each mySlide In ActivePresentation.Slides
 For i = mySlide.TimeLine.MainSequence.Count To 1 Step -1
 'Remove Each Animation
 mySlide.TimeLine.MainSequence.Item(i).Delete
 Next i
 Next mySlide
 
End Sub

保存演示文稿为PDF

您可以轻松地将Active Presentation保存为PDF格式。

Sub SavePresentationAsPDF()
 Dim pptName As String
 Dim PDFName As String
 
 ' Save PowerPoint as PDF
 pptName = ActivePresentation.FullName
 ' Replace PowerPoint file extension in the name to PDF
 PDFName = Left(pptName, InStr(pptName, ".")) & "pdf"
 ActivePresentation.ExportAsFixedFormat PDFName, 2 ' ppFixedFormatTypePDF = 2
 
End Sub

查找和替换文本

你可以在所有幻灯片的所有文本框中查找和替换文本。在你要查找的文本的第一个实例（由findWhat定义）之后，你需要通过查找命令循环查找其他实例（如果有的话）。

Sub FindAndReplaceText()
 Dim mySlide As slide
 Dim shp As Shape
 Dim findWhat As String
 Dim replaceWith As String
 Dim ShpTxt As TextRange
 Dim TmpTxt As TextRange
 
 findWhat = "jackal"
 replaceWith = "fox"
 
 ' Find and Find and Replace
 For Each mySlide In ActivePresentation.Slides
 For Each shp In mySlide.Shapes
 If shp.Type = 17 Then ' msoTextBox = 17
 Set ShpTxt = shp.TextFrame.TextRange
 'Find First Instance of "Find" word (if exists)
 Set TmpTxt = ShpTxt.Replace(findWhat, _
 Replacewhat:=replaceWith, _
 WholeWords:=True)
 
 'Find Any Additional instances of "Find" word (if exists)
 Do While Not TmpTxt Is Nothing
 Set ShpTxt = ShpTxt.Characters(TmpTxt.Start + TmpTxt.Length, ShpTxt.Length)
 Set TmpTxt = ShpTxt.Replace(findWhat, _
 Replacewhat:=replaceWith, _
 WholeWords:=True)
 Loop
 End If
 Next shp
 Next mySlide
 
End Sub

导出幻灯片为图片

您可以将Current SLide（或任何其他幻灯片）导出为PNG或JPG（JPEG）或BMP图像。

Sub ExportSlideAsImage()
 Dim imageType As String
 Dim pptName As String
 Dim imageName As String
 Dim mySlide As slide
 
 ' Export current Slide to Image
 imageType = "png" ' or jpg or bmp
 pptName = ActivePresentation.FullName
 imageName = Left(pptName, InStr(pptName, ".")) & imageType
 Set mySlide = Application.ActiveWindow.View.slide
 mySlide.Export imageName, imageType
 
End Sub

调整图像大小以覆盖整个幻灯片

Sub ResizeImageToCoverFullSlide()
 Dim mySlide As slide
 Dim shp As Shape
 
 
 ' Resize Image to full slide size
 ' Change height and width of the first shape on the current slide
 ' to fit the slide dimensions
 Set mySlide = Application.ActiveWindow.View.slide
 Set shp = mySlide.Shapes(1)
 ''
 '' Replace two statemetns above with
 '' the following statement if you want to
 '' expand the currently selected shape
 '' will give error if nothing is selected
 'Set shp = ActiveWindow.Selection.ShapeRange(1)
 
 With shp
 .LockAspectRatio = False
 .Height = ActivePresentation.PageSetup.SlideHeight
 .Width = ActivePresentation.PageSetup.SlideWidth
 .Left = 0
 .Top = 0
 End With
 
End Sub

退出所有运行中的幻灯片放映

如果你有多个SlideShow同时打开，那么你可以使用下面的宏关闭所有的SlideShow。

Sub ExitAllRunningSlideShows()
 
 Do While SlideShowWindows.Count > 0
 SlideShowWindows(1).View.Exit
 Loop
 
End Sub

从Excel自动化操作PowerPoint

您还可以通过其他应用程序（如Excel和Word）连接到PowerPoint。作为第一步，你必须引用一个PowerPoint的实例。

有两种方法可以做到这一点 - 早期绑定和后期绑定。

打开PowerPoint - 早期绑定

在 "早期绑定 "中，您必须在VBE(Visual Basic Editor)中使用 "工具->引用 "选项，显式设置 "Microsoft PowerPoint 16对象库"(适用于MS Office 2019)。

' Early Binding
Dim pptApp As Application
Set pptApp = New PowerPoint.Application

打开PowerPoint - 后期绑定

在 "后期绑定 "中，应用程序变量被声明为对象，VBA引擎在运行时连接到正确的应用程序。

' Late Binding
Dim pptApp As Object
Set pptApp = CreateObject("PowerPoint.Application")

使应用可见

在设置PowperPoint应用程序的引用后，你可能需要使其可见。

pptApp.Visible = True

操作PowerPoint

你可以从Excel使用前面描述的所有的从PowerPoint中的方法来操作演示文稿，只需添加对你上面创建的PowerPoint的引用。

举例来说

Presentations.Open ("My Presentation.pptx")

需要这样使用

pptApp .Presentations.Open ("My Presentation.pptx")

关闭应用程序

一旦你完成了你想做的PowerPoint应用程序，你必须关闭它，并应释放参考。

pptApp.Quit
Set pptApp = Nothing

从Excel复制到PowerPoint

此代码将从Excel复制一个范围到PowerPoint。

注意：为了展示如何使用VBA将一个范围从Excel复制到PowerPoint中，它尽可能地保持简单。

Sub copyRangeToPresentation()
 
' Open New PowerPoint Instance
Set pptApp = CreateObject("PowerPoint.Application")
 
With pptApp
 ' Create A New Presentation
 Set ppt = .Presentations.Add
 ' Add A Blank Slide
 Set newSlide = ppt.Slides.Add(1, 12) ' ppLayoutBlank = 12
 ' Copy Range from Active Sheet in Excel
 ActiveSheet.Range("A1:E10").Copy
 ' Paste to Powerpoint as an Image
 newSlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
 ' Switch to PowerPoint
 .Activate
End With
 
End Sub

发布于 2020-05-03 01:29

宏（编程语言）

Microsoft Office

VBA