用VBS将PPT转为图片

'使用方法：把ppt文件拖放到该文件上。   
'机器上要安装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  

 

转载于:https://www.cnblogs.com/fm168/p/3875787.html