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

飘散的云

帮帮大忙了

唐文博

请问下这些语法在哪里看啊

茹古涵今

这篇文章就是入门的内容哈

德尔家居

十分有用！感激

黄康倍

[大笑]

鬼样子

请问PPT里的形状的复制粘贴和调整功能可以支持吗？

超级小休

复制粘贴可以的，调整要看具体调整内容是什么。

猪尐烧

大神，能不能设置默认粘贴“仅保留文本”，或者新增快捷键“CTRL+t”为仅保留文本的粘贴

牛善和

可以求一个调整公式颜色的vba不
实在是外行