PowerPoint-VBA代码

PowerPoint-VBA代码

将活动的演示文稿保存为PDF格式

Sub SavePresentationAsPDF()
 Dim pptName As String
 Dim PDFName As String
 '将PowerPoint另存为PDF
 pptName = ActivePresentation.FullName
 '将名称中的PowerPoint文件扩展名替换为PDF
 PDFName = Left(pptName, InStr(pptName, ".")) & "pdf"
 ActivePresentation.ExportAsFixedFormat PDFName, 2 ' ppFixedFormatTypePDF = 2
 End Sub

创建一个新的演示文稿

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

打开一个现有的演示文稿

上面的代码假设演示文稿与包含该代码的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 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

转到特定的幻灯片

' 这将把您带到第四张幻灯片
Application.ActiveWindow.View.GotoSlide (4)

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

' 从幻灯片3移到第一张幻灯片
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
'对变量‘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
'对变量'shp'中引用的当前形状执行某些操作。
'例如，在即时窗口中打印形状的名称
 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
        Debug.Print shp.Name
'Debug.Print 调试打印结果
    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
'检查形状类型是否为msoTextBox
    If shp.Type = 17 Then   ' msoTextBox文本框 = 17
'打印文本框中的文本
 Debug.Print shp.TextFrame2.TextRange.Text
 End If
Next shp

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

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

Dim currentSlide as Slide Dim shp as Shape
For Each currentSlide In ActivePresentation.Slides
 For Each shp In currentSlide.Shapes
 '检查形状类型是否为msoTextBox
 If shp.Type = 17 Then ' msoTextBox文本框 = 17
 '对变量’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
'保存对当前演示文稿的引用
Set currentPresentation = Application.ActivePresentation
'保存对当前幻灯片的引用
Set currentSlide = Application.ActiveWindow.View.Slide
'添加新演示文稿并保存到引用
Set NewPresentation = Application.Presentations.Add
'复制选定的幻灯片
Selection.Copy
'粘贴到新演示文稿中
NewPresentation.Slides.Paste

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

'复制当前幻灯片
Application.ActiveWindow.View.Slide.Copy
' 粘贴在末尾
ActivePresentation.Slides.Paste

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

Sub ChangeSlideDuringSlideShow()
 Dim SlideIndex As Integer
 Dim SlideIndexPrevious As Integer
'在放映幻灯片时将当前幻灯片更改为选定的幻灯片4
 SlideIndex = 4
 '当前幻灯片放映窗口的索引是SlideShowWindows集合中的1
 SlideIndexPrevious = SlideShowWindows(1).View.CurrentShowPosition
 SlideShowWindows(1).View.GotoSlide SlideIndex
End Sub

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

Sub ChangeFontOnAllSlides()
 Dim mySlide As slide
 Dim shp As Shape
 ' 更改所有幻灯片上的字体大小
 For Each mySlide In ActivePresentation.Slides
 For Each shp In mySlide.Shapes
 If shp.Type = 17 Then ' msoTextBox文本框 = 17
 ' 将字体大小更改为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
 '将所有幻灯片的大小写更改为普通大小写
 For Each mySlide In ActivePresentation.Slides
 For Each shp In mySlide.Shapes
    If shp.Type = 17 Then ' msoTextBox文本框 = 17
 ' 将大写字母更改为正常大小写
 shp.TextFrame2.TextRange.Font.Allcaps = False
 End If
 Next shp
 Next mySlide
End Sub

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

Sub ToggleCaseBetweenUpperAndNormal()
 Dim mySlide As slide
 Dim shp As Shape
 '  在所有幻灯片的大写和普通大小写之间切换
 For Each mySlide In ActivePresentation.Slides
 For Each shp In mySlide.Shapes
 If shp.Type = 17 Then ' msoTextBox = 17
 ' 在大写和普通大小写之间切换
 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删除下划线()
 Dim mySlide As Slide
 Dim shp As Shape
 Dim descenders_list As String
 Dim phrase As String
 Dim x As Long
   descenders_list = "gjpqy"
 For Each mySlide In ActivePresentation.Slides
    For Each shp In mySlide.Shapes
    If shp.Type = 17 Then ' msoTextBox文本框 = 17
        ' 去掉字母“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
    '从最后倒数删除每个动画
         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
    '活动演示文稿全名赋值给变量
 pptName = ActivePresentation.FullName
 ' 将名称中的PowerPoint文件扩展名替换为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"
 ' 查找、查找和替换
 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”单词的第一个实例(如果存在)
 Set TmpTxt = ShpTxt.Replace(findWhat, _
 Replacewhat:=replaceWith, _
 WholeWords:=True)
 '查找“Find”单词的任何其他实例(如果存在)
 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
 ' 将当前幻灯片导出为图像
 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
'将图像大小调整为完整幻灯片大小。
'更改当前幻灯片上第一个形状的高度和宽度。
'以适应幻灯片尺寸
Set mySlide = Application.ActiveWindow.View.slide
Set shp = mySlide.Shapes(1)
'如果要展开当前选定的形状，将上面的两个语句替换为以下语句。
    '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()
'打开新的PowerPoint实例
Set pptApp = CreateObject("PowerPoint.Application")
With pptApp
 '创建新演示文稿
 Set ppt = .Presentations.Add
 ' 添加空白幻灯片
 Set newSlide = ppt.Slides.Add(1, 12) ' ppLayoutBlank = 12
 ' 在Excel中从活动工作表复制区域
 ActiveSheet.Range("A1:E10").Copy
 ' 粘贴到Powerpoint作为图像
 newSlide.Shapes.PasteSpecial DataType:=2 '2=PP粘贴增强型元文件
 ' 切换到PowerPoint
 .Activate
End With
End Sub