Question

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

有没有办法创建一个VBA例程，可以做一个foreach并识别每个页面上每个图像或对象的大小，帮助我追踪匪徒并权衡哪些幻灯片保持/简化/放弃？< / p>

Answer 1

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

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

无论如何，可以完成，由对PowerPoint有很多了解的人完成。

PPTFAQ网站还有很多其他可能有用的信息，说明可能导致文件膨胀的原因。例如关于WMF，幻灯片主模板，光栅图像等

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

嵌入或链接对象的WMF包含任何位图数据，即PPT   文件臃肿。＆gt; [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") & "\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

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

1 个答案: