批处理之家 - Powered by Discuz! Board

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

作者: hzliew 时间: 2016-7-15 20:43 标题: 批处理如何打开指定目录下（包含子目录）的ppt文件并另存到其他目录

本帖最后由 pcl_test 于 2016-7-16 14:34 编辑

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

作者: hzliew 时间: 2016-7-15 22:12

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

作者: gawk 时间: 2016-7-15 22:27

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

作者: hzliew 时间: 2016-7-15 22:31

本帖最后由 pcl_test 于 2016-7-16 00:51 编辑

回复 3# gawk

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

作者: hzliew 时间: 2016-7-16 09:52

我编写了一个脚本，但该脚本只能找到“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 时间: 2016-7-16 10:46

拿去花

@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 时间: 2016-7-16 11:20

本帖最后由 hzliew 于 2016-7-16 11:21 编辑

回复 6# WHY

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

请按任意键继续...

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

作者: ygqiang 时间: 2016-7-16 11:43

回复 7# hzliew

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

作者: hzliew 时间: 2016-7-16 12:20

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

作者: pcl_test 时间: 2016-7-16 12:29

本帖最后由 pcl_test 于 2016-7-16 19:05 编辑

试试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 时间: 2016-7-16 12:36

本帖最后由 hzliew 于 2016-7-16 12:40 编辑

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

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

作者: pcl_test 时间: 2016-7-16 12:38

回复 11# hzliew

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

作者: hzliew 时间: 2016-7-16 12:41

回复 hzliew

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

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

作者: hzliew 时间: 2016-7-16 12:52

本帖最后由 hzliew 于 2016-7-16 12:55 编辑

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

作者: pcl_test 时间: 2016-7-16 14:11

回复 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)  '插入图片
复制代码

作者: hzliew 时间: 2016-7-16 15:36

本帖最后由 hzliew 于 2016-7-16 15:53 编辑

回复 hzliew

xp你重新安装微软的Office软件
pcl_test 发表于 2016-7-16 14:11

真没想到是office自身的问题，重装office就好了，谢谢您的提醒。再次感谢您以及6楼的兄弟，以非常牛X的而且不同的思路和视角解决了此问题。

追加一个问题：能否在保存这些文件时保持原来文件的目录结构？比如，源目录中D:\test\chap1\1.ppt, D:\test\chap2\1.ppt, D:\test\chap3\1.ppt, 转换到E:\Temp后，分别为E:\Temp\chap1\1.ppt，E:\Temp\chap2\1.ppt，E:\Temp\chap3\1.ppt，也就是让那些上千个ppt文件分别保存在各自不同的章节目录里，只是根目录变了，其他不变？

作者: hzliew 时间: 2016-7-16 16:46

本帖最后由 pcl_test 于 2016-7-24 19:47 编辑

回复 10# pcl_test

我仿照您的代码来转换doc文档，为何提示33行类型不匹配：

Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set ws = CreateObject("WScript.Shell")
wordApp.visible = true
srcFolder = "D:\test"  '源文件夹
dstFolder = "E:\Temp"  '目标文件夹
If Not fso.FolderExists(dstFolder) Then fso.CreateFolder(dstFolder)
Call getSubFiles(srcFolder, "doc")
wordApp.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
            SaveAsDOC Folder, file
        End If
    Next
      
    For Each SubFolder In SubFolders
        Call getSubFiles(SubFolder.Path, extension)
    Next
    
    Set Folder = nothing
    Set SubFolders = nothing
End Function

Function SaveAsDOC(folder, file)  '增加保留源文件目录结构
    newpath = replace(LCase(Left(folder.Path, Len(srcFolder)))&Mid(folder.Path, Len(srcFolder)+1), LCase(srcFolder), dstFolder)
    If Not fso.FolderExists(newpath) Then ws.run "cmd /c md """&newpath&"", 0
    Set doc = wordApp.Documents.Open(file.Path)
    doc.SaveAs(newpath&"\"&file.Name)
    doc.Close
End Function
复制代码

作者: WHY 时间: 2016-7-16 18:00

本帖最后由 WHY 于 2016-7-17 00:30 编辑

回复 16# hzliew

@if (0)==(0) echo off
set "srcDir=D:\Test"
set "dstDir=E:\Temp"
xcopy /s /t "%srcDir%\*" "%dstDir%\"
dir /b /a-d /s "%srcDir%\*.ppt" | cscript //nologo //e:jscript "%~f0" "%srcDir%" "%dstDir%"
(for /f "delims=" %%i in ('dir /b /ad /s "%dstDir%\*" ^| sort /r') do rd "%%i") 2>nul
pause & exit
@end

var arr = WSH.Arguments;
var reg = new RegExp('^' + arr(0).replace(/[\^$+\-\\()[\]{}.]/g, '\\$&'), 'i');
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 strNewFile = strFile.replace(reg, arr(1));
    var objPres = objApp.Presentations.Open(strFile, false, false, false);
    objPres.SaveAs(strNewFile);
    objPres.Close();
}

objApp.Quit()
复制代码

正则表达式漏掉特殊字符“.” 补上

作者: WHY 时间: 2016-7-16 18:05

回复 17# hzliew

把 33 行改成 File.Path

作者: hzliew 时间: 2016-7-16 18:21

回复 19# WHY

还是您火眼金睛啊。。。

作者: hzliew 时间: 2016-7-16 18:23

回复 hzliew
WHY 发表于 2016-7-16 18:00

哇塞，兄弟真牛B，代码简洁，堪称完美！佩服佩服！

作者: pcl_test 时间: 2016-7-16 19:10

回复 17# hzliew

17楼已改

作者: hzliew 时间: 2016-7-16 21:25

回复 hzliew

17楼已改
pcl_test 发表于 2016-7-16 19:10

经测试运行，您的代码正确无误。至此，问题圆满解决，谢谢！

作者: WHY 时间: 2016-7-22 23:59

我觉得 pcl_test 版主17楼的vbs方案考虑不够周全

假设doc文件全部位于 E:\Temp 目录的下一级目录，创建文件夹会失败
另外，假设 srcFolder 变量值为D:\test，而实际目录名为D:\TEST
由于vbs的replace方法区分大小写，字符串不会被替换

作者: WHY 时间: 2016-7-23 11:45

Dim srcDir, dstDir, fso, objApp

srcDir = "D:\Test"
dstDir = "E:\Temp"

Set fso = CreateObject("Scripting.FileSystemObject")
Set objApp = CreateObject("PowerPoint.Application")
objApp.Visible = True

Call EnumFiles(srcDir)

objApp.Quit
Set objApp = Nothing : Set fso = Nothing

Function EnumFiles(strPath)
    Dim objFile, strExt, arr, strNewFile, objFolder
    For Each objFile In fso.GetFolder(strPath).Files
        strExt = fso.GetExtensionName(objFile.Path)
        If LCase(Left(strExt, 3)) = "ppt" Then
            strNewFile = Replace(objFile.Path, srcDir, dstDir, 1, 1, 1)
            arr = Split(strNewFile, "\")
            If UBound(arr) > 1 Then Call CreateSubFolder(arr)
            Call SaveFile(objFile.Path, strNewFile)
        End If
    Next
      
    For Each objFolder In fso.GetFolder(strPath).SubFolders
        Call EnumFiles(objFolder.Path)
    Next
End Function

Function CreateSubFolder(ByVal arr)
    Dim i, strSubFolder
    strSubFolder = arr(0)
    For i = 1 To UBound(arr) - 1
        strSubFolder = strSubFolder & "\" & arr(i)
        If Not fso.FolderExists(strSubFolder) Then fso.CreateFolder(strSubFolder)
    Next
End Function

Function SaveFile(strFile, ByVal strNewFile)
    Dim objPres
    Set objPres = objApp.Presentations.Open(strFile, false, false, false)
    objPres.SaveAs(strNewFile)
    objPres.Close
    Set objPres = Nothing
End Function
复制代码

作者: pcl_test 时间: 2016-7-23 15:15

回复 24# WHY

已改

欢迎光临批处理之家 (http://bbs.bathome.net/)