' 创建文件系统对象
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 = Nothing
复制代码

' 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 If
复制代码