您当前的位置:首页 > 文本与office

ppt超级压缩工具

时间:11-23来源:作者:点击数:

最近忙期末复习,才发现老师的课件都是 20MB 一个一个的,暴汗。分析了下,发现很多嵌入式的声音,而这些声音都是wav格式的,所以ppt被撑暴了,很不爽,所以研究了半个小时 Powerpoint.Application 这个VBA COM对象,写了个 SoundButtonRipper.vbs。

原理很简单,遍历一个ppt的所有形状(Presentation.Shapes),如果是自动绘图对象(AutoShape)并且类型是135(Sound Button),那么删除这个形状,最后另存为 原文件名_ripped.ppt

Windows Vista Ultimate 32bit, Windows Script Host 5.7, Office 2007 with VBA 测试通过

'======================================
'
'SoundButtonRipper.vbs V1.0
'
'Author:  est
'Email:    electroniXtar@Gmail.com
'Modified:  14:36 2007/7/9
'
'======================================
'全局变量
Dim PptApp, PptPre
Set PptApp=CreateObject("powerpoint.application")
PptApp.Visible=True '必须为True否则出错
PptApp.WindowState=1 '最小化以免影响视线
WScript.Sleep 1000
Function RipSndBtns(strFilePath)
Set PptPre=PptApp.Presentations.Open(strFilePath) '必须是完整路径,出错就用 8.3 路径
'Set PptPre=PptApp.ActivePresentation '测试用
For Each PptSlide In PptPre.Slides
  For Each PptShape In PptSlide.Shapes
    'WScript.Echo PptSlide.SlideIndex & "  " & PptShape.Type & "  " & PptShape.Id & "  " & PptShape.AutoShapeType 测试用
    If PptShape.Type=1 And PptShape.AutoShapeType=135 Then
        PptShape.Delete
    End If
  Next
Next
'分析ppt的路径,另存为 原文件名_ripped.ppt
strPathPart=Split(strFilePath,"\")
strFileName=strPathPart(UBound(strPathPart))
lenFileName=Len(strFileName)
Call PptPre.Saveas(Left(strFilePath,Len(strFilepath)-lenFileName) & Left(strfilename,lenFileName-4)&"_ripped.ppt")
Call PptPre.Close()
End Function
Call RipSndBtns(WScript.Arguments(0))
PptApp.Quit
'"E:\script\Powerpoint.Application\1.ppt" '测试用

测试了一下,一个20MB的ppt被压缩成 613KB,再WinRAR一下300KB,爽。

方便获取更多学习、工作、生活信息请关注本站微信公众号城东书院 微信服务号城东书院 微信订阅号
推荐内容
相关内容
栏目更新
栏目热门