其实不一定需要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
有个地方不小心写错了,用这个代码吧 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
如若能解决,再发一帖送一百分。
新建一个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
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