hzliew

回复  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

回复 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

回复 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

回复 17# hzliew


    把 33 行改成 File.Path

hzliew

回复 19# WHY


    还是您火眼金睛啊。。。

hzliew

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

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

pcl_test

回复 17# hzliew

17楼已改

hzliew

回复  hzliew

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

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

WHY

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

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

WHY

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

回复 24# WHY

已改