复制内容到剪贴板
代码:
'/////////////////////////////
'/PowerPoint文件转图像脚本(ppt2img)
'/作者:[url]www.51windows.net[/url]，海娃
'/使用方法：将此文件放在sendto文件中，然后在ppt文件上点右键，发送到，ppt2img.vbs中，输入要输出图像的格式，然后输入图像的宽与高，脚本会生成一个同名的文件，里面为生成的图像文件。
'/机器上要安装Powerpoint程序
'/////////////////////////////
'on error resume next
Set ArgObj = WScript.Arguments
pptfilepath = ArgObj(0)
imgType = InputBox("输入导出文件的格式，可以是jpg,png,bmp,gif","输入导出文件的格式","png")
if imgType = "" or (lcase(imgType)<>"jpg" and lcase(imgType)<>"png" and lcase(imgType)<>"bmp" and lcase(imgType)<>"gif") then
imgType = "png"
msgbox "输入不正确，以png格式输出"
end if
imgW = InputBox("输入导出图像的宽度","输入导出图像的宽度","640")
if imgW = "" or isnumeric(imgW)=false then
imgW = 640
msgbox "输入不正确,程序使用默认值:640"
end if
imgH = InputBox("输入导出图像的高度","输入导出图像的高度","480")
if imgH = "" or isnumeric(imgH)=false then
imgH = imgW*0.75
msgbox "输入不正确,程序使用默认值:"&imgH
end if
call Form_Load(pptfilepath,imgType)
Private Sub Form_Load(Filepath,format)
if format = "" then
format = "gif"
end if
Folderpath = left(Filepath,len(Filepath)-4)
if lcase(right(Filepath,4))<>".ppt" then
call ConvertPPT(Filepath,Folderpath&".ppt")
end if
Filepath = Folderpath&".ppt"
CreateFolder(Folderpath)
Set ppApp = CreateObject("PowerPoint.Application")
Set ppPresentations = ppApp.Presentations
Set ppPres = ppPresentations.Open(Filepath, -1, 0, 0)
Set ppSlides = ppPres.Slides
For i = 1 To ppSlides.Count
iname = "000000"&i
iname = right(iname,4)'取四位数
Call ppSlides.Item(i).Export(Folderpath&"\"&iname&"."&format, format, imgW, imgH)
Next
Set ppApp = Nothing
Set ppPres = Nothing
End Sub
Function CreateFolder(Filepath)
Dim fso, f
on error resume next
Set fso = CreateObject("Scripting.FileSystemObject")
if not fso.FolderExists(Filepath) then
Set f = fso.CreateFolder(Filepath)
end if
CreateFolder = f.Path
set fso = Nothing
set f = Nothing
End Function
Sub ConvertPPT(FileName1, FileName2)
Dim PPT
Dim Pres
Set PPT = CreateObject("PowerPoint.Application")
Set Pres = PPT.Presentations.Open(FileName1, False, False, False)
Pres.SaveAs FileName2, , True
Pres.Close
PPT.Quit
Set Pres = Nothing
Set PPT = Nothing
End Sub
