VBS 利用pdftk 依关键字，合并多文件夹下PDF文件到一个PDF文件

cqz1314

感谢，感谢。

通过网盘分享的文件：pdftk合并多个PDF到1个PDF文件.rar
链接: https://pan.baidu.com/s/1ZAbSX9q2J3IVviQymdFf9g?pwd=gtt4 提取码: gtt4
--来自百度网盘超级会员v9的分享

上面是需要的示例文件
下面是想实现的操作
=====
求VBS代码
pdftk 所在目录下有 若干个文件夹 每个文件中有不同数量的PDF文件 想把文件名中包含相同关键字
如“张三，李四，王五，牛七”的文件合并成一个文件，
合并后的文件文件放在 月日四位日期编号+个人学习资料 文件夹内  如0104个人学习资料



“张三，李四，王五，牛七”
是把有上述关键的PDF文件合并到以关键字+的个人学习资料+日期  如，张三的个人学习资料1.4.pdf
日期格式用月.日，如1月4日就是1.4
另外 生成新文件的文件夹月份前面少了一个0



完成后，提示是否删除源文件。

下面是AI写的代码，没成功，不知道有没有借鉴意义。

' 创建文件系统对象
Set fso = CreateObject("Scripting.FileSystemObject")
 
' 定义要搜索的关键字
Dim keywords
keywords = Array("张三", "李四", "王五", "牛七")
 
' 获取当前目录
Dim currentDir
currentDir = fso.GetAbsolutePathName(".")
 
' 获取当前日期并修改格式为月日（两位）用于文件夹名称
Dim folderDate
folderDate = Right("0" & Month(Date), 2) & Right("0" & Day(Date), 2)
 
' 获取当前日期并修改格式为月.日用于 PDF 文件名
Dim pdfDate
pdfDate = Month(Date) & "." & Day(Date)
 
 
' 存储要合并的文件列表
Dim mergeList
Set mergeList = CreateObject("System.Collections.ArrayList")
 
 
' 遍历当前目录下的所有文件夹
Dim subFolder
For Each subFolder In fso.GetFolder(currentDir).SubFolders
    ' 遍历每个子文件夹中的文件
    Dim file
    For Each file In subFolder.Files
        Dim fileName
        fileName = file.Name
        Dim i
        For i = 0 To UBound(keywords)
            If InStr(fileName, keywords(i)) > 0 Then
                ' 确保文件存在且可访问，并且是 PDF 文件
                If fso.FileExists(file.Path) And LCase(Right(file.Path, 4)) = ".pdf" Then
                    ' 对文件路径进行更严谨的处理，去除可能的多余空格和特殊字符
                    Dim cleanPath
                    cleanPath = Trim(file.Path)
                    mergeList.Add("""" & Replace(cleanPath, """", "\""") & """") 
                End If
                Exit For
            End If
        Next
    Next
End For
 
 
' 遍历关键字并执行合并操作
Dim keyword
For Each keyword In keywords
    ' 定义目标文件夹
    Dim targetFolder
    targetFolder = currentDir & "\" & folderDate & "个人学习资料" & "\" & keyword & "的个人学习资料"
    
    ' 检查并创建目标文件夹
    If Not fso.FolderExists(targetFolder) Then
        fso.CreateFolder(targetFolder)
    End If
    
    ' 构建合并命令
    Dim command
    Dim pdftkPath
    pdftkPath = fso.BuildPath(currentDir, "pdftk.exe")
    command = """" & pdftkPath & """ "
    Dim subMergeList
    Set subMergeList = CreateObject("System.Collections.ArrayList")
    For Each item In mergeList
        If InStr(item, keyword) > 0 Then
            subMergeList.Add(item)
        End If
    End If
    Dim itemList
    itemList = ""
    For Each item In subMergeList
        itemList = itemList & item & " "
    Next
    command = command & itemList & "cat output " & """" & targetFolder & "\" & keyword & "的个人学习资料" & pdfDate & ".pdf"""
    
    ' 执行合并命令
    Dim shell
    Set shell = CreateObject("WScript.Shell")
    On Error Resume Next ' 开启错误处理
    shell.Run command, 1, True ' 显示窗口，方便查看错误信息
    If Err.Number <> 0 Then
        WScript.Echo "执行命令时出错: " & Err.Description & " 命令: " & command
        Err.Clear
    End If
    On Error GoTo 0 ' 关闭错误处理
    Set shell = Nothing
    Set subMergeList = Nothing
Next
 
 
' 释放对象
Set fso = Nothing
Set mergeList = NothingCOPY

cqz1314

回复 6# flashercs


    感谢

flashercs

上面修改了

cqz1314

回复 2# flashercs


    你好，合并文件结束后，我想让代码直接删除源文件所在的文件夹，只保留合并后的文件夹，帮我改一下，谢谢

cqz1314

回复 2# flashercs


    你好，合并文件结束后，我想让代码直接删除源文件所在的文件夹，只保留合并后的文件平，帮我改一下，谢谢

cqz1314

回复 2# flashercs


    感谢 测试成功

flashercs

' On Error Resume Next ' 开启错误处理
' 创建文件系统对象
Set fso = CreateObject("Scripting.FileSystemObject")
 
' 定义要搜索的关键字
Dim keywords
keywords = Array("张三", "李四", "王五", "牛七")
 
' 获取当前目录
Dim currentDir
currentDir = fso.GetAbsolutePathName(".")
 
' 获取当前日期并修改格式为月日（两位）用于文件夹名称
Dim folderDate
folderDate = Right("0" & Month(Date), 2) & Right("0" & Day(Date), 2)
 
' 获取当前日期并修改格式为月.日用于 PDF 文件名
Dim pdfDate
pdfDate = Month(Date) & "." & Day(Date)
 
 
Dim command
Dim pdftkPath
pdftkPath = fso.BuildPath(currentDir, "pdftk.exe")
Dim shell
Set shell = CreateObject("WScript.Shell")
 
' WScript.Quit
' 遍历关键字并执行合并操作
Dim keyword,targetFolderRoot
targetFolderRoot = currentDir & "\" & folderDate & "个人学习资料"
If Not fso.FolderExists(targetFolderRoot) Then
   fso.CreateFolder targetFolderRoot
End If
For Each keyword In keywords
    ' 定义目标文件夹
    Dim targetFolder
    targetFolder = targetFolderRoot & "\" & keyword & "的个人学习资料"
    
    ' 检查并创建目标文件夹
    If Not fso.FolderExists(targetFolder) Then
        fso.CreateFolder targetFolder
    End If
    
    ' 构建合并命令
    command = """" & pdftkPath & """ "
 
    For Each subFolder In fso.GetFolder(currentDir).SubFolders
        If subFolder.Path <> targetFolderRoot Then
            For Each file In subFolder.Files
                If InStr(1,file.Name, keyword,vbTextCompare) > 0 And LCase(fso.GetExtensionName(file.Name)) = "pdf" Then
                    command = command & """" & file.Path & """ "
                End If
            Next
        End If
    Next
    command = command & " cat output " & """" & targetFolder & "\" & keyword & "的个人学习资料" & pdfDate & ".pdf"""
 
    ' 执行合并命令
    shell.Run command, 0, True ' 显示窗口，方便查看错误信息
    If Err.Number <> 0 Then
        WScript.Echo "执行命令时出错: " & Err.Description & " 命令: " & command
        Err.Clear
    End If
    
Next
Dim result
result = MsgBox("PDF合并完成,是否删除原文件所在的文件夹?", vbQuestion Or vbYesNo Or vbSystemModal, "提示")
If result = 6 Then
    ' 删除原文件所在的文件夹
    For Each subFolder In fso.GetFolder(currentDir).SubFolders
        If subFolder.Path <> targetFolderRoot Then
            subFolder.Delete True
        End If
    Next
End IfCOPY