vba - Powerpoint VBA 脚本可以识别每张幻灯片上图像元素的大小吗？

Question

我有一个超过大小限制的 PPT，可以通过电子邮件发送。我已经压缩了每张幻灯片上的图像。我想了解哪些幻灯片使文件膨胀。

有没有一种方法可以创建一个 VBA 例程，该例程可以执行 foreach 并确定每个页面上每个图像或对象的大小，帮助我找出罪魁祸首并权衡哪些幻灯片要保留/简化/删除？

Answer 1

似乎有一个PPTFAQ链接到的插件，它将识别膨胀的来源，尽管它不适用于 PPT 2007+ 文件格式（PPTM/PPTX 等），并且可能不适用于 PPT 版本 2007 +

http://billdilworth.mvps.org/SizeMe.htm

在任何情况下，都可以由对 PowerPoint 非常了解的人来完成。

PPTFAQ 站点有很多其他可能有用的信息，这些信息可能会导致您的文件膨胀。例如关于 WMF、幻灯片母版模板、光栅图像等。

PowerPoint 有一些默认设置，当您尝试减小文件大小时，这些设置会对您不利...

嵌入或链接对象的 WMF 包含任何位图数据，您的 PPT 文件膨胀。> [Windows 元文件] 可以包含位图图像，但只能作为未压缩的 BMP...

当您启用审阅时，PowerPoint 将原始演示文稿的副本存储为隐藏的 OLE 对象 - 这是稍后编辑时与演示文稿本身进行比较的基线。

等等

更新

这不适用于 PPT 2011 / Mac 版的 PowerPoint。我对 Ron DeBruin 的函数进行了一些尝试，并很快将其组合在一起，我不确定它对 OP 有多大用处，但将来可能对其他人有价值。

OptionalHTMLExtract允许您从 ZIP 或 HTML 转换。我最初做 HTML 是因为它看起来更容易，但后来想出了如何做 ZIP 版本，所以我包括了这两个选项。

Option Explicit
Sub GetMediaSizes()
    Dim DefPath As String
    'Destination folder
    DefPath = "C:\Users\" & Environ("username") & "\desktop\PPT_Report\"    '<<< Change path as needed
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
    
    ExtractPPTFile DefPath
    InspectFiles DefPath

    'Use Shell to open the destination folder
    Shell "C:\WINDOWS\explorer.exe """ & DefPath, vbNormalFocus

End Sub

Sub InspectFiles(fPath As String, Optional HTMLExtract As Boolean = False)
    Dim FSO As Object           'Scripting.FileSystemObject
    Dim fldr As Object          'Scripting.Folder
    Dim fl As Object            'Scripting.File
    Dim i As Long               'counter variable
    Dim txtFile As Object       'text file
    Dim fileInfo() As Variant   'An array to hold file informations
    Dim txtFilePath As String   'path for storing the log/report
    Dim extractPath As String   'path for the exported HTML components
    
    txtFilePath = fPath & "Report.txt"
    extractPath = fPath & IIf(HTMLExtract, "Extract_Files", "ppt\media") '"Extract_Files" for the HTML
    
    Set FSO = CreateObject("scripting.filesystemobject")
    Set fldr = FSO.GetFolder(extractPath)
    ReDim fileInfo(fldr.Files.Count)
    For Each fl In fldr.Files
        Select Case UCase(Right(fl.Name, 3))
            Case "GIF", "BMP", "PNG", "JPG" ' inspect only image files, modify as needed
                fileInfo(i) = fl.Name & vbTab & fl.Size
                i = i + 1
            Case Else
            ' Do nothing
        End Select
    Next
    Set txtFile = FSO.CreateTextFile(txtFilePath, True, True)
    txtFile.Write Join(fileInfo, vbNewLine)
    txtFile.Close
    
    Set txtFile = Nothing
    Set fldr = Nothing
    Set fl = Nothing
    Set FSO = Nothing

End Sub


Sub ExtractPPTFile(fPath As String, Optional HTMLExtract As Boolean = False)
    'Based on
    'http://www.rondebruin.nl/win/s7/win002.htm

    Dim FSO As Object
    Dim pres As Presentation
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim fDialog As FileDialog
    Dim oApp As Object
    Dim ext As String
    Dim tempName As String
    
    Set fDialog = Application.FileDialog(msoFileDialogOpen)
    fDialog.AllowMultiSelect = False
    fDialog.Show
    

    If fDialog.SelectedItems.Count = (0) Then
        'Do nothing
    Else
        Fname = fDialog.SelectedItems(1)
        FileNameFolder = fPath
        Set FSO = CreateObject("scripting.filesystemobject")
        If Not FSO.FolderExists(fPath) Then
            FSO.CreateFolder fPath
        End If
        'Comment these lines if you do NOT want to delete all the files in the folder DefPath first if you want
        On Error Resume Next
        Kill fPath & "*.*"
        On Error GoTo 0

        If HTMLExtract Then
            fDialog.Execute
            'Extract the files into the Destination folder
            Set pres = Presentations.Open(Fname)
            ActivePresentation.SaveAs fPath & "Extract.htm", ppSaveAsHTML, msoFalse
            ActivePresentation.Close
            Presentations(Fname).Close
        Else:

        ext = Mid(Fname, InStrRev(Fname, "."))
        tempName = Replace(Fname, ext, ".zip")
        Name Fname As tempName
        Set oApp = CreateObject("Shell.Application")
            oApp.Namespace(CVar(fPath)).CopyHere oApp.Namespace(CVar(tempName)).items
            On Error Resume Next
            FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
        End If
        Name tempName As Fname
    End If
End Sub