解决方案 »

  1.   

    急用啊,好多ppt要批量处理。一个个地点进去太费事了。
    如若能解决,再发一帖送一百分。
      

  2.   

    其实不一定需要VBS(可能因为我不太擅长调试VBS代码吧)
    新建一个pptm文件(不要把它放到你要处理的那些pptx文件目录下,因为他的作用只是为了运行VBA代码)(pptm启用宏的ppt文件,其实用pptx也可以,只不过不能保存宏,当然这些都是office07版的东西,如果是老版本的话直接就用.ppt文件就可以吧,我没有老版本所以没有试)
    把下面的代码写入,然后运行
    Function SaveShape(pptObj, filePath As String, outputPath As String)Dim ppt
    'Set pptObj = CreateObject("PowerPoint.Application")
    Set ppt = pptObj.Presentations.Open(fileName:=filePath, ReadOnly:=msoFalse)  Dim fileFullName
      fileFullName = Split(filePath, ".")
      fileFullName = Split(fileFullName(0), "\")
      Dim fileName As String
      fileName = fileFullName(UBound(fileFullName))
      
      Dim mySlide As Slide
      Dim myShape As Shape, i_Temp As Integer
      On Error Resume Next
      For Each mySlide In ActivePresentation.Slides
         For Each myShape In mySlide.Shapes
           i_Temp = i_Temp + 1
           myShape.Export pathName:=outputPath & fileName & "-" & i_Temp & ".gif", Filter:=ppShapeFormatGIF
         Next
      Next
    ppt.Close
    End Function
     
    Sub GetAllImages()Dim filesPath As String 'ppt文件目录
    Dim outputPath As String '输出文件目录
    filePath = "D:\"
    outputPath = "E:\"Dim Fso As Object
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Dim pptObj
    Set pptObj = CreateObject("PowerPoint.Application")
    For Each Fld In Fso.getfolder(filesPath).FilesIf UBound(Split(Fld.Path, ".")) > 0 Then
    If Split(Fld.Path, ".")(1) = "pptx" Or Split(Fld.Path, ".")(1) = "ppt" Then
    SaveShape pptObj, Fld.Path, outputPath
    End If
    End IfNextEnd Sub
      

  3.   

    有个地方不小心写错了,用这个代码吧
    Function SaveShape(pptObj, filePath As String, outputPath As String)Dim ppt
    'Set pptObj = CreateObject("PowerPoint.Application")
    Set ppt = pptObj.Presentations.Open(fileName:=filePath, ReadOnly:=msoFalse)  Dim fileFullName
      fileFullName = Split(filePath, ".")
      fileFullName = Split(fileFullName(0), "\")
      Dim fileName As String
      fileName = fileFullName(UBound(fileFullName))
      
      Dim mySlide As Slide
      Dim myShape As Shape, i_Temp As Integer
      On Error Resume Next
      For Each mySlide In ActivePresentation.Slides
         For Each myShape In mySlide.Shapes
           i_Temp = i_Temp + 1
           myShape.Export pathName:=outputPath & fileName & "-" & i_Temp & ".gif", Filter:=ppShapeFormatGIF
         Next
      Next
    ppt.Close
    End Function
     
    Sub GetAllImages()Dim filesPath As String 'ppt文件目录
    Dim outputPath As String '输出文件目录
    filesPath = "D:\"
    outputPath = "E:\"Dim Fso As Object
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Dim pptObj
    Set pptObj = CreateObject("PowerPoint.Application")
    For Each Fld In Fso.getfolder(filesPath).FilesIf UBound(Split(Fld.Path, ".")) > 0 Then
    If Split(Fld.Path, ".")(1) = "pptx" Or Split(Fld.Path, ".")(1) = "ppt" Then
    SaveShape pptObj, Fld.Path, outputPath
    End If
    End IfNextEnd Sub