[文件操作] 批处理如何打开指定目录下（包含子目录）的ppt文件并另存到其他目录

hzliew

请教：搜索某个目录（比如D:\课件，包含子目录）下的所有ppt文件，逐一打开然并以原文件名另存到另一个目录下（比如E:\temp）后关闭，直到所有的文件都执行完毕。请问这个批处理怎么写？先谢谢了。

hzliew

或者谁能告诉我，如何用批处理命令实现对ppt文件的另存为也可以，不是复制，是打开后另存为哦。谢谢。

gawk

能够介绍一下这样操作的目的是啥？

hzliew

回复 3# gawk


    回楼上的：原因比较特殊，极少数人会碰到这个问题。由于我的课件被内部加入了水印，直接拷贝出去在别的电脑会无法读取。但如果先打开后再另存为到一个特殊目录，即可脱掉水印，就可以拷贝了。课件比较多，所以希望批处理。方法不限，能用VBS语法实现也行。

hzliew

我编写了一个脚本，但该脚本只能找到“C：\”根目录下的ppt文件，如何找到某目录（包含子目录）下的所有ppt文件并进行保存?我的脚本如下：
strComputer = "."
on error resume next
Set objWMIService = GetObject("winmgmts:" _
     & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set pptApp = CreateObject("PowerPoint.application")
Set FileList = objWMIService.ExecQuery _
     ("ASSOCIATORS OF {Win32_Directory.Name='c:'} Where " _
         & "ResultClass = CIM_DataFile")
For Each objFile In FileList
     If objFile.Extension = "ppt" Then
  pptApp.visible = true
  Set pptSelection = pptApp.Presentations.Open("c:\" & objFile.FileName & "." & objFile.Extension)
  pptSelection.SaveAs("c:\" & objFile.FileName & "2.ppt")
  pptSelection.close
     End If
Next
pptApp.quit

WHY

拿去花

@if (0)==(0) echo off
set "srcDir=D:\test"
set "dstDir=E:\Temp"
md "%dstDir%" 2>nul
dir /b /a-d /s "%srcDir%\*.ppt" | cscript //nologo //e:jscript "%~f0" "%dstDir%"
pause & exit
@end

var dstDir = WSH.Arguments(0) + '\\';
var fso = new ActiveXObject('Scripting.FileSystemObject');
var objApp = new ActiveXObject('PowerPoint.Application');
objApp.Visible = true;

while(!WSH.StdIn.AtEndOfStream){
    var strFile = WSH.StdIn.ReadLine();
    var strName = fso.GetBaseName(strFile);
    var strNewFile = dstDir + strName + '.ppt';
    var i = 0;
    while(fso.FileExists(strNewFile))strNewFile = dstDir + strName + '(' + (++i) + ').ppt';
    var objPres = objApp.Presentations.Open(strFile, false, false, false);
    objPres.SaveAs(strNewFile, 1, false);
    objPres.Close();
}

objApp.Quit()
复制代码

hzliew

回复 6# WHY


    谢谢，不过失败了。我将你的代码保存为convert.bat，放在D:\test 下运行（该目录放了一个样本ppt文件），得到出错提示：
D:\test\convert.bat<11,1>Microsoft JScript 运行时错误： Automation 服务器不能创建对象

请按任意键继续...

我的系统为XP系统，是否跟系统有关？

ygqiang

回复 7# hzliew


    6楼代码，win7 64系统测试成功。

hzliew

问题出在var objApp = new ActiveXObject('PowerPoint.Application');这一行上。难道XP系统对调用ActiveXObject很敏感？

pcl_test

试试vbs会不会报错

Dim i
Set fso = CreateObject("Scripting.FileSystemObject")
Set pptApp = CreateObject("PowerPoint.application")
pptApp.visible = true
srcFolder = "D:\ppt"  '源文件夹
dstFolder = "E:\另存"  '目标文件夹
If Not fso.FolderExists(dstFolder) Then fso.CreateFolder(dstFolder)
Call getSubFiles(srcFolder, "ppt")
pptApp.Quit
msgbox "Done"

'遍历文件夹查找指定扩展名文件
Function getSubFiles(path, extension)
    Set Folder = fso.GetFolder(path)
    Set SubFolders = Folder.SubFolders
      
    Set Files = Folder.Files
    For Each File In Files
        If LCase(Right(File.Name, Len(extension))) = LCase(extension) Then
            SaveAsPPT File
        End If
    Next
      
    For Each SubFolder In SubFolders
        Call getSubFiles(SubFolder.Path, extension)
    Next
    
    Set Folder = nothing
    Set SubFolders = nothing
End Function

Function SaveAsPPT(file)
    i=i+1  '避免重名
    Set ppt = pptApp.Presentations.Open(file.Path)
    ppt.SaveAs(dstFolder&"\"&i&"_"&file.Name)
    ppt.Close
End Function
复制代码

hzliew

试试vbs会不会报错
pcl_test 发表于 2016-7-16 12:29

    WIN7下测试成功，下面试试XP系统

pcl_test

回复 11# hzliew

ppt的所在文件夹你改成你自己的没？

hzliew

回复  hzliew

ppt的所在文件夹你改成你自己的没？
pcl_test 发表于 2016-7-16 12:38

    不好意思，刚忘了改。改了WIN7下是成功的，现在看看XP。

hzliew

怎么插入截图啊，XP系统下还是那个问题，第3行：ActiveX部件不能创建对象：“PowerPoint application”，看来这是XP系统的顽疾。。。

pcl_test

回复 14# hzliew

xp你重新安装微软的Office软件

Set pptApp = CreateObject("PowerPoint.application")
file = "D:\ppt\2.ppt"  'ppt文件
pic = "D:\ppt\2.jpg"  '需插入的图片
pptApp.visible = true
Set ppt = pptApp.Presentations.Open(file)
Set slide = ppt.Slides(1)  '第一张幻灯片
Call slide.Shapes.AddPicture(pic, False, True, 100, 100, 400, 400)  '插入图片
复制代码