时间戳

首页 > 解决方案 > 更改纵横比而不失真且边缘没有黑条（取决于播放的屏幕尺寸）

vba - 更改纵横比而不失真且边缘没有黑条（取决于播放的屏幕尺寸）

问题描述

我有一组两个 PowerPoint 演示文稿，我使用 VBA 进行了编码以进行交互（一个具有允许在另一个中导航的按钮）。最初这些将显示在静态屏幕上，所以我定义了它们的大小以完美地适应屏幕，以便它们填满屏幕并彼此相邻，看起来像一个应用程序。但是，由于 Covid，现在将在演讲厅的投影仪上显示，每次使用不同的笔记本电脑，因此我需要动态演示并根据用户的屏幕进行调整。

我设法编写这样的代码，以便演示文稿根据用户填充屏幕。查看我的代码（请注意，此代码不会打开两个演示文稿，因为我在外部也有代码，因此可以通过单击 VBScript 文件在外部打开整个内容）：

Sub Resize_Presentations()

Dim PPT1 As Object
Set PPT1 = CreateObject("PowerPoint.Application")
Set PPT1 = Presentations("Stand-up Wall - From Drive\Stand Up Title Page - With Macros.pptm")

Dim PPT2 As Object
Set PPT2 = CreateObject("PowerPoint.Application")
Set PPT2 = Presentations("Stand Up Summary and Breakdowns - With Macros.pptm")

'define screen height and width for resizing'
PPT1.Application.ActiveWindow.WindowState = ppWindowMaximized
windWidth = Application.Width
windHeight = Application.Height

'minimise windows for playing presentations'
PPT1.Application.ActiveWindow.WindowState = ppWindowMinimized
PPT2.Application.ActiveWindow.WindowState = ppWindowMinimized

'play title presentation in defined size'
With PPT1.SlideShowSettings
    .ShowType = ppShowTypeSpeaker
    
With .Run
    .Top = 0
    .Left = 0
    .Width = windWidth / 3
    .Height = windHeight
End With
End With

'play breakdown and summary presentation in defined size'
With PPT2.SlideShowSettings
    .ShowType = ppShowTypeSpeaker
    
With .Run
    .Top = 0
    .Left = windWidth / 3
    .Width = (windWidth / 3) * 2
    .Height = windHeight
End With
End With

End Sub
Sub Open_Presentation()

Dim Ret
Dim Ret2

Dim PPT1 As Object
Set PPT1 = CreateObject("PowerPoint.Application")

Dim PPT2 As Object
Set PPT2 = CreateObject("PowerPoint.Application")

Ret = IsWorkBookOpen("C:\Users\RobinsonH7\Desktop\Stand-up Wall - From Drive\Stand Up Title Page - With Macros.pptm")
Ret2 = IsWorkBookOpen("C:\Users\RobinsonH7\Desktop\Stand-up Wall - From Drive\Stand Up Summary and Breakdowns - With Macros.pptm")

If Ret = True And Ret2 = False Then

Set PPT1 = Presentations("Stand-up Wall - From Drive\Stand Up Title Page - With Macros.pptm")
Set PPT2 = Presentations.Open(FileName:="C:\Users\RobinsonH7\Desktop\Stand-up Wall - From Drive\Stand Up Summary and Breakdowns - With Macros.pptm")

Call Resize_Presentations

Else: MsgBox "Close all stand-up wall slides"
End If

End Sub
Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

我尝试添加的内容：

理想情况下，我只想调整演示文稿在播放时的呈现方式，就像演示文稿被拉伸或缩放以适应空间一样。任何帮助将不胜感激！

提前致谢！

标签： vbapowerpoint

解决方案

由于 PowerPoint 的开发历史，到达幻灯片母版的语法有点神秘。您指的是设计而不是 SlideMaster！以下是评估是否存在多个幻灯片母版的声明：

If ActivePresentation.Designs.Count > 1 Then

要对具有多个幻灯片母版的演示文稿中的幻灯片母版形状进行操作：

For Z = 1 To ActivePresentation.Designs.Count
    For Each objShape In ActivePresentation.Designs(Z).SlideMaster.Shapes

调整大小后，您的代码必须找到每个形状以将它们调整回原来的比例。在 2010 年之后的所有 PowerPoint 版本中，演示文稿高度保持在 7.5" 不变，只有宽度变化。4x3 为 10"，16x10 为 12"，16x9 为 13.33"。因此，您实际上只需要更改图形的宽度即可将它们恢复到正确的比例。

作为替代方法，您可以使用PPTools Resize之类的加载项。或者您可以使用具有 4x3、16x10 和 16x9 纵横比变体的 SuperTheme，它将覆盖 99.99% 的显示器。以下是有关 SuperThemes 如何工作的更多信息：SuperThemes

推荐阅读