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 有多大用处，但将来可能对其他人有价值。

可选HTMLExtract允许您从 ZIP 或 HTML 进行转换。我最初做了 HTML，因为它看起来更容易，但后来弄清楚了如何做 ZIP 版本，所以我包括了这两个选项。

Option Explicit
Sub GetMediaSizes()
    Dim DefPath As String
    'Destination folder
    DefPath = "C:Users" & Environ("username") & "desktopPPT_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:WINDOWSexplorer.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", "pptmedia") '"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